Selecting the same item from a vba range

user_14432243 0
Viewed 54

enter image description hereThe code below copies values from another workbook. However, instead of copying values exactly the way they appear in the source workbook, I want it to copy items of the same kind (all of them), insert a blank row, and copy another of the same kind. Example attached.

    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

enter image description here

excel-formula vba excel
1 Answers

Copy Duplicated Rows to a New Workbook

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
user_98140690
Related