如何行從表具有多個條目複製在同一列

Question

我有一個報告表，顯示是這樣的：

Agent Name Acct Number data  data  data etc. 

Alex   213   data  data  data etc. 

Alex   123   data  data  data etc. 

Alex   4334   data  data  data etc. 

David  23432   data  data  data etc. 

David  2342   data  data  data etc. 

Angel  1111   data  data  data etc. 

Angel  1111   data  data  data etc. 

首先，我創建存儲在一個主模板的副本單獨的表格。然後我將它命名爲陣列中第一個人的姓名。

For z = 2 To jLastRow 

    Sheets("Template").copy After:=Sheets(Sheets.Count) 
    ActiveSheet.name = MyNames(i) '~~> retrieve from array 

    Sheets("From DB Report").Activate 

    While MyNames(i) = MyNames(i + 1) 

     For Each myrange In Range("a2", Range("a60000").End(xlUp)) 

       Rows(myrange.Row).EntireRow.copy 
       Sheets(MyNames(i)).Cells(myrange.Row * 2, 1).PasteSpecial xlValues 
       i = i + 1 
       If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1) 

       Exit For       

     Next myrange 
    Wend 


Next 

我想要做的是將選定的整個行復制到新工作表。然後我想繼續循環，而第一個人（myNames（i））仍然是一樣的，並繼續複製那些數據的行。

我需要做的是對數組中的其餘名稱進行完全相同的操作。我想最後爲每個名稱和所有數據（按行）複製一張表。

我得到複製工作表，但我似乎無法得到複製的行。只有一行拷貝。任何幫助wouild是偉大的讚賞！

更新：我的IT部門剛給了我這組代碼，該代碼適用於列表中的第一個名稱，但它不會繼續循環直到找到下一個不同的名稱來複制和重命名。

Sub CopyDataFromReportToIndividualSheets() 
    Dim ws As Worksheet 
    Set ws = Sheets("From DB Report") 
    Dim LastRow As Long 
    Dim MyRange As Range 

    Worksheets("From DB Report").Activate 

    LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row 

    ' stop processing if we don't have any data 
    If LastRow < 2 Then Exit Sub 


    Application.ScreenUpdating = False 
    ' SortMasterList LastRow, ws 
    CopyDataToSheets LastRow, ws 
    ws.Select 
    Application.ScreenUpdating = True 
End Sub 

Sub SortMasterList(LastRow As Long, ws As Worksheet) 
    ws.Range("A2:BO" & LastRow).Sort Key1:=ws.Range("A1") ' , Key2:=ws.Range("B1") 
End Sub 

Sub CopyDataToSheets(LastRow As Long, src As Worksheet) 
    Dim rng As Range 
    Dim cell As Range 
    Dim Series As String 
    Dim SeriesStart As Long 
    Dim SeriesLast As Long 

    Set rng = Range("A2:A" & LastRow) 
    SeriesStart = 2 
    Series = Range("A" & SeriesStart).Value 
    For Each cell In rng 
     If cell.Value <> " " Then 
      SeriesLast = cell.Row - 1 
      CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 
      Series = cell.Value 
      SeriesStart = cell.Row 
     End If 
    Next 
    ' copy the last series 
    SeriesLast = LastRow 
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 

End Sub 

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _ 
                 name As String) 
    Dim tgt As Worksheet 
    Dim MyRange As Range 

    If (SheetExists(name)) Then 
     MsgBox "Sheet " & name & " already exists. " _ 
     & "Please delete or move existing sheets before" _ 
     & " copying data from the Master List.", vbCritical, _ 
     "Time Series Parser" 
     End 
    Else 
     If Series = " " Then 
      End 
     End If 

    End If 

    Worksheets("Template").Activate 

    ' Worksheets.Add(after:=Worksheets(Worksheets.Count)).name = name 
    Worksheets("Template").copy After:=Worksheets(Worksheets.Count) 
    ActiveSheet.name = name 

    Set tgt = Sheets(name) 

    ' copy data from src to tgt 
    tgt.Range("A2:BO2" & Last - Start + 2).Value = src.Range("A" & Start & ":BO" & Last).Value 


End Sub 

Function SheetExists(name As String) As Boolean 
    Dim ws As Worksheet 

    SheetExists = True 
    On Error Resume Next 
    Set ws = Sheets(name) 
    If ws Is Nothing Then 
     SheetExists = False 
    End If 
End Function 

這似乎取消了名稱數組。如果需要，我將如何瀏覽列表並使用唯一名稱填充數組，然後解析要複製的行？

再次感謝！

Answer 1

您編寫的以下代碼，Exit For語句每次都會執行。

  If MyNames(i) <> MyNames(i + 1) Then MyNames(i) = MyNames(i + 1) 

      Exit For 

如果你想退出的僅環MyNames(i) <> MyNames(i+1)，你需要下面寫：

  If MyNames(i) <> MyNames(i + 1) Then 
       MyNames(i) = MyNames(i + 1) 
       Exit For 
      End If 

---

更新。

我重寫2點的過程，

Function SheetExists(name As String) As Boolean 
    Dim ws As Variant 

    For Each ws In ThisWorkbook.Sheets 
     If ws.name = name Then 

      SheetExists = True 
      Exit Function 

     End If 
    Next 

    SheetExists = False 

End Function 

你不應該依賴「上的錯誤繼續下一步」在可能的情況。

接下來，CopyDataToSheets過程中，您沒有比較cell.Value和Series。 因此，Macro嘗試在每一行中複製（並創建新工作表）。

Sub CopyDataToSheets(LastRow As Long, src As Worksheet) 
    Dim allAgentNameCells As Range 
    Dim cell As Range 
    Dim Series As String 
    Dim SeriesStart As Long 
    Dim SeriesLast As Long 

    Set allAgentNameCells = Range("A2:A" & LastRow) 
    SeriesStart = 2 
    Series = Range("A" & SeriesStart).Value 

    For Each cell In allAgentNameCells 

     If cell.Value <> " " And cell.Value <> "" Then 
      ' Condition ` And cell.Value <> "" ` added for my testdata. If you don't need this, please remove. 

      ' Current Row's Series not SPACE 

      If cell.Value <> Series Then 
       SeriesLast = cell.Row - 1 
       CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 
       Series = cell.Value 
       SeriesStart = cell.Row 
      End If 
     End If 
    Next 

    '' copy the last series 
    SeriesLast = LastRow 
    CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series 

End Sub 

在我的Excel中，這看起來像工作正常。 您的數據如何？