☰

复制唯一数量的行，并用空行分隔

tag-icon • tag-icon microsoft-excel vba macros
复制唯一数量的行，并用空行分隔

。 你好！

我有一个包含客户姓名的长列表（>500 行，12 列），中间用空行分隔。它看起来像这样：

客户名单

我需要将每个唯一客户（例如“Peter”）的所有行复制到另一张表中。我尝试录制宏并使用了以下组合控制和转移和上/下/右箭头复制每个客户的值，然后跳转到下一个客户。

我尝试为列表中的前三个客户（Peter、Adam、Sara）生成通用代码，并将值粘贴到另一张表中。我得到了以下代码：

Sub COPY_CUSTOMERS()
'
' COPY_CUSTOMERS Makro
'

'
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet(2)").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A8").Select
    Sheets("Customers").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet(2)").Select
    ActiveSheet.Paste
    Sheets("Customers").Select
    Selection.End(xlDown).Select
    
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet(2)").Select
    Range("A10").Select
    ActiveSheet.Paste
    Sheets("Customers").Select
    Selection.End(xlDown).Select
End Sub

对于仅出现在一行中的客户，不能应用以下代码：

Range(Selection, Selection.End(xlDown)).Select

因此我不确定如何解决这个问题，因为行号总是不同的，所以要选择唯一的值。

如有任何帮助或建议，我将不胜感激。

谢谢，并致以最诚挚的问候，

季度报告

答案1

您似乎希望每个客户都在一张单独的表格上。

由于我看到顶行有向下的箭头，因此我假设您的数据在表格中（VBA 中的 ListObject）。如果不是这样，则代码可能需要进行一些修改。

我还做了一些其他的假设

算法

  • 使用字典对象创建唯一的客户列表
  • 为每个客户过滤表格
    • 将可见单元格写入客户的工作表
    • 我假设客户工作表名称与客户名称相同
    • 如果该表不存在，则将创建该表。
    • 粘贴目标设置为A9
      • 但是如果之前已经粘贴了某些内容，我们将粘贴到当前数据下方，省略标题行。
Option Explicit
Sub splitCustomersToSheets()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim LO As ListObject, dCust As Object
    Dim v, w, C As Range
    
Set dCust = CreateObject("Scripting.Dictionary")
    dCust.comparemode = vbTextCompare 'case insensitive
    
Set wsSrc = Worksheets("Sheet2")
Set LO = wsSrc.ListObjects("tblCustomers") 'or whatever

'Generate list of customers
'faster to loop through vba array than through range on the worksheet
v = LO.DataBodyRange.Columns(2)
For Each w In v
    Select Case w <> ""
        Case True
            If Not dCust.exists(w) Then dCust.Add w, w
    End Select
Next w

'Copy each name to it's own worksheet
For Each v In dCust.keys

    'if worksheet not present, add it
    On Error Resume Next
    Set wsDest = Worksheets(v)
    Select Case Err.Number
        Case 9
             ThisWorkbook.Worksheets.Add
             ActiveSheet.Name = v
             Set wsDest = Worksheets(v)
        Case Is <> 0
            MsgBox "Error Number: " & Err.Number & vbLf & Err.Description
            Exit Sub
    End Select
    On Error GoTo 0
    
    With wsDest
    Set C = .Cells(9, 1)
        If C <> "" Then 'already stuff on the page, paste below range
            Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End With
    
    'copy the data
    LO.AutoFilter.ShowAllData
    LO.Range.AutoFilter Field:=2, Criteria1:=v
    
    'if sheet not empty, then don't copy the header row
    If C.Row = 9 Then
        LO.Range.SpecialCells(xlCellTypeVisible).Copy C
    Else
        LO.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy C
    End If
        
Next v

End Sub

如果您的数据不是在真正的 Excel 表中，那么您可以尝试以下代码：

Option Explicit
Sub splitCustomersToSheets()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim R As Range, dCust As Object
    Dim v, w, C As Range
    Dim lR As Long, lC As Long
    
Set dCust = CreateObject("Scripting.Dictionary")
    dCust.comparemode = vbTextCompare 'case insensitive
    
Set wsSrc = Worksheets("Sheet2")
With wsSrc
    lR = .Cells(.Rows.Count, 1).End(xlUp).Row
    lC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set R = .Range(.Cells(1, 1), .Cells(lR, lC))
End With
    
'Generate list of customers
'faster to loop through vba array than through range on the worksheet
v = R.Columns(2).Offset(1, 0)
For Each w In v
    Select Case w <> ""
        Case True
            If Not dCust.exists(w) Then dCust.Add w, w
    End Select
Next w

'Copy each name to it's own worksheet
For Each v In dCust.keys

    'if worksheet not present, add it
    On Error Resume Next
    Set wsDest = Worksheets(v)
    Select Case Err.Number
        Case 9
             ThisWorkbook.Worksheets.Add
             ActiveSheet.Name = v
             Set wsDest = Worksheets(v)
        Case Is <> 0
            MsgBox "Error Number: " & Err.Number & vbLf & Err.Description
            Exit Sub
    End Select
    On Error GoTo 0
    
    With wsDest
    Set C = .Cells(9, 1)
        If C <> "" Then 'already stuff on the page, paste below range
            Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End With
    
    'copy the data
    Application.ScreenUpdating = False
    On Error Resume Next 'in case no filter is set
        wsSrc.ShowAllData
    On Error GoTo 0
    R.AutoFilter Field:=2, Criteria1:=v
    
    'if sheet not empty, then don't copy the header row
    If C.Row = 9 Then
        R.SpecialCells(xlCellTypeVisible).Copy C
    Else
        R.Offset(1, 0).Resize(R.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy C
    End If
        
Next v

End Sub

答案2

假设您的目标表已经存在：

Sub croupier()
    Dim N As Long, i As Long, j As Long
    
    N = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To N
        v = Cells(i, "B").Value
        If v <> "" Then
            j = Sheets(v).Cells(Rows.Count, "A").End(xlUp).Row + 1
            Cells(i, 1).EntireRow.Copy Sheets(v).Cells(j, 1)
        End If
    Next i
End Sub

如果目标工作表有标题行，则不会被覆盖。

相关内容