Excel的VBA到列表複製到新的工作表

我有包含Excel中的人的詳細信息，這包含城市，地址和名稱Excel的VBA到列表複製到新的工作表

我需要搶市列，併爲每個城市工作表中的列表，然後複製從sheet1到新工作表的數據。

因此，如果例如我有一個名爲都柏林的城市，我需要創建一個名爲dublin的新工作表，進入列表，抓取所有名爲dublin的城市，將它們複製並粘貼到都柏林工作表中作爲其他列當然）

我正在使用宏的形式鏈接：http://www.mrexcel.com/forum/excel-questions/727407-visual-basic-applications-split-data-into-multiple-worksheets-based-column.html由mirabeau創建。

的代碼如下：

Sub columntosheets() 

Const sname As String = "Sheet1" 'change to whatever starting sheet 
Const s As String = "A" 'change to whatever criterion column 
Dim d As Object, a, cc& 
Dim p&, i&, rws&, cls& 
Set d = CreateObject("scripting.dictionary") 
With Sheets(sname) 
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
    cc = .Columns(s).Column 
End With 
For Each sh In Worksheets 
    d(sh.Name) = 1 
Next sh 

Application.ScreenUpdating = False 
With Sheets.Add(after:=Sheets(sname)) 
    Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1) 
    .Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes 
    a = .Cells(cc).Resize(rws + 1, 1) 
    p = 2 
    For i = 2 To rws + 1 
     If a(i, 1) <> a(p, 1) Then 
      If d(a(p, 1)) <> 1 Then 
       Sheets.Add.Name = a(p, 1) 
       .Cells(1).Resize(, cls).Copy Cells(1) 
       .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1) 
      End If 
      p = i 
     End If 
    Next i 
    Application.DisplayAlerts = False 
    .Delete 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
End With 
Sheets(sname).Activate 

End Sub

以上是能夠爲每個城市創建的工作表，但不會將數據複製到新創建的工作表。如何才能做到這一點？我對VBA的知識非常有限，完全喪失了這一點。

來源

2015-07-01 Matthew Cremona

您是否嘗試複製工作表，按城市排序，然後刪除您不需要的順序？這樣你就不必擔心複製任何東西。 – Lumigraphics

一旦創建了所有工作表，您只需在清單中搜索城市。對於每條線，查看城市，並將其寫入相應的表格中。工作表需要與我的代碼工作的城市名稱相同。

我假設你在A列開始，第1行

dim strCity as string 
dim strAdd as string 
dim strName as string 
for i = 1 to Sheets("[TableSheet]").Cells(Rows.Count, "A").End(xlUp).row 
    strCity = Sheets("[TableSheet]").range("A" & i) 
    strAdd = Sheets("[TableSheet]").range("B" & i) 
    strName = Sheets("[TableSheet]").range("C" & i) 

    Sheets(strCity).Range("A" & i) = strCity 
    Sheets(strCity).Range("B" & i) = strAdd 
    Sheets(strCity).Range("C" & i) = strName 
next

當然[tableSheet]是該板與你的信息。如果你不udnerstand和有疑問，我可以很高興地回答的名字。

來源

2015-07-01 20:24:41

嘿大衛！感謝您的回覆，我遇到了下面發佈的運行時錯誤，任何提示？對不起，如果我可能會問愚蠢的問題，但我正試圖用我非常有限的知識來簡化一些非常忙碌的工作。 –

該循環可能過於遙遠。可能會給strName分配一個空值，導致Sheets（strname）崩潰。如果你嘗試使用i = 1 To Sheets（「[TableSheet]」）。Cells（Rows.Count，「B」）。End（xlUp）.Row - 1，它是否工作？它甚至可以用於最後的值還是會跳過？如果不是，我建議在代碼的末尾添加一個以查看它掉到哪裏。乾杯! –

感謝您的迅速回復。我用它在一個簡單的列表中，它工作正常。不過，我把它應用到一個稍微複雜的場景和編輯的代碼如下：

Dim strDB As String 
 
Dim strName As String 
 
Dim strDate As String 
 
Dim strHour As String 
 
Dim strMin As String 
 
Dim strGR As String 
 

 
For i = 1 To Sheets("[TableSheet]").Cells(Rows.Count, "B").End(xlUp).Row 
 
    strDB = Sheets("[TableSheet]").Range("A" & i) 
 
    strName = Sheets("[TableSheet]").Range("B" & i) 
 
    strDate = Sheets("[TableSheet]").Range("C" & i) 
 
    strHour = Sheets("[TableSheet]").Range("D" & i) 
 
    strMin = Sheets("[TableSheet]").Range("E" & i) 
 
    strGR = Sheets("[TableSheet]").Range("F" & i) 
 

 
    Sheets(strName).Range("A" & i) = strDB 
 
    Sheets(strName).Range("B" & i) = strName 
 
    Sheets(strName).Range("C" & i) = strDate 
 
    Sheets(strName).Range("D" & i) = strHour 
 
    Sheets(strName).Range("E" & i) = strMin 
 
    Sheets(strName).Range("F" & i) = strGR 
 
Next

我需要在B列進行排序每當我運行它，我不斷收到一個運行時錯誤「 9'下標超出範圍。我知道這意味着什麼，但我無法找到代碼中出錯的地方。

來源

2015-07-01 22:01:53

Excel的VBA到列表複製到新的工作表

回答

相關問題