如何从表单中复制具有多个条目的行

我从一个报告中看到一个表单，

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. 

首先，我创build一个存储在一个单独的工作表中的主模板的副本。 然后我将它命名为数组中第一个人的名字。

 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部门刚刚给了我这套代码，它工作在列表中的名字，但它不会继续循环，直到find下一个不同的名称来复制和重命名。

 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 

这似乎取消了一系列的名字。 如果需要的话，我将如何浏览列表并用唯一名称填充数组，然后parsing要复制的行？

再次感谢！

Answer 1

下面你写的代码， Exit For语句每次都会执行。

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

如果你只想退出for循环MyNames(i) <> MyNames(i+1) ，你需要写下面：

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

---

更新。

我重写了两个程序，

 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 

如果可能的话，不应该依赖“On Error Resume Next”。

接下来，CopyDataToSheets程序，你没有比较cell.Value和Series。 所以，macros试图复制（并创build新的工作表）在每一行。

 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中，这看起来像工作正常。 如何处理你的数据？