VBA-如果列包含不同的字符串，则复制行并将其分组

我有一个包含客户信息的excel文件。在第6列中可以找到客户名称。我有一个扫描特定客户名称的代码，如果它符合条件，它会将整行复制到新的工作表中。 到现在为止，一直都还不错。但是我希望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

这就是代码的基本功能：

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

以下是我想要它做的：

我该怎么做呢？任何帮助都将受到感激并提前感谢

我将您的复制脚本缩短为

或
语句

将所需行复制到sheet2后，将按F列对工作表进行排序，以对客户进行分组

添加了客户的标题。因此，它在F列中循环，当客户更改时，会添加一个标题

---

subtestcopy（）
Dim aCol尽可能长
Dim MaxRowList为长，U行为长，x行为长
将wsSource设置为工作表，将wsTarget设置为工作表
设置wsSource=ThisWorkbook.Worksheets（“Sheet1”）
Set-wsTarget=ThisWorkbook.Worksheets（“Sheet2”）
aCol=1
MaxRowList=wsSource.Cells（Rows.Count，aCol）.End（xlUp）.Row
第二行=1
对于x=2到MaxRowList
如果指令（1，wsSource.Cells（x，6），“Customer1”）或_
仪表（1，wsSource.Cells（x，6），“Customer2”）或_
InStr（1，wsSource.Cells（x，6），“Customer3”）然后
wsTarget.Rows（destiny\u row）.Value=wsSource.Rows（x）.Value
destiny\u行=destiny\u行+1
如果结束
下一个
'按客户列F排序
使用wsTarget.Sort
.SortFields.Clear
.SortFields.Add Key:=Range（“F:F”），SortOn:=xlSortOnValues，Order:=xlAscending，DataOption:=xlSortNormal
.SetRange wsTarget.UsedRange
.方向=xlTopToBottom
.SortMethod=xl拼音
.申请
以
'为客户添加标题
Dim max_row尽可能长，我尽可能长
将最后一个客户设置为字符串
最大行=命运行
i=1
lastCustomer=“”
在我离开的时候做
如果wsTarget.Cells（i，“F”）.为lastCustomer赋值，则“如果当前客户与上一客户不同
lastCustomer=wsTarget.Cells（i，“F”）.Value“记住最后一个客户”
wsTarget.Rows（i）.Insert Shift:=xlDown'在上面添加一行
wsTarget.Cells（i，1）.Value=lastCustomer'将客户写为标题
max_row=max_row+1'因为我们添加了一行，最后一行向下移动了一行
如果结束
i=i+1'转到下一行
环
端接头

工作表是否按F列（客户）排序？否，它是按随机顺序排序的。然后，我建议复制所需的行，就像您对工作表2所做的那样。然后按F列对表2进行排序，以便将要分组的客户站在一起。最后，从上到下循环F列单元格，每次客户更改时，都会添加一个带有客户名称的标题。@Peh-如果要插入行，它应该从下到上循环。@Jeeped yes两者都可以。如果将i=1的

从上到下添加到maxRow

并添加行，那么每次添加行时显然需要将+1添加到

maxRow

。但自下而上可能更直观。谢谢。只需添加工作表（“Sheet2”）。在标题添加开始之前选择，就像标题添加到当前打开的工作表而不是Sheet2一样。我的坏：（而不是

.Select

（如果可能，不应使用Select，因为它会减慢Excel的速度）我建议使用

wsTarget。

我更改了答案以更正此问题。

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