从VBA范围中选择同一项目

Question

以下代码复制了另一个工作簿中的值。但是，我希望它在源工作簿中出现的方式复制它们，而是希望它复制相同类型的项目（全部），插入空白行，然后复制另一种相同类型的项目。附加的示例。

    Sub NewWBandPasteSpecialALLSheets()
       Dim wb As Workbook
       Dim wbNew As Workbook
       Dim sh As Worksheet
       Dim shNew As Worksheet
    
       Set wb = ThisWorkbook
       Workbooks.Add                
       Set wbNew = ActiveWorkbook
    
       On Error Resume Next
    
       For Each sh In wb.Worksheets
          sh.Range("C1:C180, D1:D180,E1:E180, F1:F180, G1:G180").Copy ' I want this range to copy groups of items that are the same and insert a row.
    
          With wbNew.Worksheets
    
              Set shNew = Nothing
              Set shNew = .Item(sh.Name)
    
              If shNew Is Nothing Then
                  .Add After:=.Item(.Count)
                  .Item(.Count).Name = sh.Name
                  Set shNew = .Item(.Count)
              End If
               End With
    
    
          With shNew.Range("A1")
              .PasteSpecial (xlPasteColumnWidths)
              .PasteSpecial (xlValues)
          End With
       Next
    End Sub

Answer 1

将重复的行复制到新工作簿

Option Explicit

Sub NewWBandPasteSpecialALLSheets()
       
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim sData As Variant
    Dim srCount As Long, sr As Long
    
    Dim dws As Worksheet
    Dim dData As Variant
    Dim drCount As Long, dr As Long, dn As Long
    
    Dim cCount As Long, c As Long
    Dim FirstDone As Boolean
    
    For Each sws In swb.Worksheets
        
        Set srg = sws.Range("C1:G180")
        
        If Not FirstDone Then
            srCount = srg.Rows.Count
            drCount = 2 * srCount
            cCount = srg.Columns.Count
        End If
        
        sData = srg.Value
        
        ReDim dData(1 To drCount, 1 To cCount)
        dr = 0
        
        For sr = 1 To srCount
            For dn = 1 To 2
                dr = dr + 1
                For c = 1 To cCount
                    dData(dr, c) = sData(sr, c)
                Next c
            Next dn
        Next sr
        
        If FirstDone Then
           Set dws = dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count))
        Else
           Set dws = dwb.Worksheets(1)
           FirstDone = True
        End If
        
        dws.Name = sws.Name
          
        With dws.Range("A1")
            .Resize(drCount, cCount).Value = dData
            srg.Copy
            .PasteSpecial xlPasteColumnWidths
            Application.Goto .Cells, True
        End With
    
    Next sws
    
    Application.Goto dwb.Worksheets(1).Range("A1")
    
    MsgBox "Data copied.", vbInformation
    
End Sub