VBA – 如果列包含不同的string并对它们进行分组，则复制行

我有一个关于客户信息的excel文件。 在第6列中，可以find客户名称。 我有一个代码扫描某些客户名称，如果它符合标准，它将整个行复制到一个新的工作表。 到现在为止还挺好。 但是我希望VBA脚本能够在下一个之间对客户进行“分组”。

这是我目前的代码：

Sub testcopy() Dim wsSource As Worksheet Dim wsTarget As Worksheet Set wsSource = ThisWorkbook.Worksheets("Sheet1") Set wsTarget = ThisWorkbook.Worksheets("Sheet2") aCol = 1 MaxRowList = wsSource.Cells(Rows.Count, aCol).End(xlUp).Row destiny_row = 2 For x = 2 To MaxRowList If InStr(1, wsSource.Cells(x, 6), "Customer1") Then wsTarget.Rows(destiny_row).Value = wsSource.Rows(x).Value destiny_row = destiny_row + 1 End If If InStr(1, wsSource.Cells(x, 6), "Customer2") Then wsTarget.Rows(destiny_row).Value = wsSource.Rows(x).Value destiny_row = destiny_row + 1 End If If InStr(1, wsSource.Cells(x, 6), "Customer3") Then wsTarget.Rows(destiny_row).Value = wsSource.Rows(x).Value destiny_row = destiny_row + 1 End If Next 

这就是代码的基本function：

我希望它进一步按客户分组。

这是我想要的：

我将如何去做呢？ 任何帮助表示感谢，并提前致谢！

Answer 1

1. 我把你的副本脚本缩短为OR语句。
2. 将所需的行复制到工作表2后，工作表按列Fsorting，以将客户分组。
3. 客户的头条新增。 因此，它通过F列循环，并且当顾客改变标题被添加时。

---

 Sub testcopy() Dim aCol As Long Dim MaxRowList As Long, destiny_row As Long, x As Long Dim wsSource As Worksheet, wsTarget As Worksheet Set wsSource = ThisWorkbook.Worksheets("Sheet1") Set wsTarget = ThisWorkbook.Worksheets("Sheet2") aCol = 1 MaxRowList = wsSource.Cells(Rows.Count, aCol).End(xlUp).Row destiny_row = 1 For x = 2 To MaxRowList If InStr(1, wsSource.Cells(x, 6), "Customer1") Or _ InStr(1, wsSource.Cells(x, 6), "Customer2") Or _ InStr(1, wsSource.Cells(x, 6), "Customer3") Then wsTarget.Rows(destiny_row).Value = wsSource.Rows(x).Value destiny_row = destiny_row + 1 End If Next ' Sort by Customer column F With wsTarget.Sort .SortFields.Clear .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange wsTarget.UsedRange .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' Add the headlines for Customers Dim max_row As Long, i As Long Dim lastCustomer As String max_row = destiny_row i = 1 lastCustomer = "" Do While i < max_row If wsTarget.Cells(i, "F").Value <> lastCustomer Then 'if current customer is different from last customer lastCustomer = wsTarget.Cells(i, "F").Value 'remember last customer wsTarget.Rows(i).Insert Shift:=xlDown 'add a row above wsTarget.Cells(i, 1).Value = lastCustomer 'write the customer as headline max_row = max_row + 1 'because we added a row the last row moved one row down End If i = i + 1 'goto next row Loop End Sub