I want to combine data from multiple sheets. The sheets all have the same autogenerated name: A, A(2), A(3) etc. I can select the data and paste it in the combined sheet for the first sheet (A) but I cannot get it to work for any of the following sheets. The Issue is that I cannot use <> "combined" because there are other sheets (B,C & D) from which I do not need/want the data. Nor can I just name all the sheets because the number of sheets A(#) is variable too so I get an error when I try. So far this is the part that works:

Sheets("A").Select

Dim rgSelect As Range, c As Range
 For Each c In ActiveSheet.Range("B:B")
 If Not c = 0 Then
 If rgSelect Is Nothing Then Set rgSelect = c
 Set rgSelect = Union(rgSelect, c)
 
 End If
 Next c
 rgSelect.EntireRow.Copy Destination:=Sheets("Combined").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

 
 Sheets("Combined").Select

Do you perhaps know a solution? I was reading about INDIRECT function but so far I haven't been able to get that to work

CodePudding user response：

Use the comparison operator Like

Option Explicit

Sub combine()
    Dim wb As Workbook, ws As Worksheet, wsCmb As Worksheet
    Dim rngCmb As Range, rngSelect As Range, c As Range
    Dim lastrow As Long, i As Long, n As Long, msg As String
    Dim t0 As Single: t0 = Timer
    
    Set wb = ThisWorkbook
    Set wsCmb = wb.Sheets("Combined")
    With wsCmb
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngCmb = .Cells(lastrow   1, "A")
    End With
    
    Application.ScreenUpdating = False
    For Each ws In wb.Sheets
        If ws.Name = "A" Or ws.Name Like "A(*)" Then

            Set rngSelect = Nothing
            n = 0
            With ws
               lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
               ' select rows
               For Each c In .Range("B1:B" & lastrow)
                    If c <> 0 Then
                        If rngSelect Is Nothing Then Set rngSelect = c
                        Set rngSelect = Union(rngSelect, c)
                        n = n   1
                    End If
               Next
               
               ' copy to combined
               If n > 0 Then
                   rngSelect.EntireRow.Copy rngCmb
                   Set rngCmb = rngCmb.Offset(n)
               End If
               msg = msg & vbLf & n & " rows from " & ws.Name

            End With
        End If
    Next
    wsCmb.Select
    Application.ScreenUpdating = True
    MsgBox "Sheets combined " & msg, vbInformation, Format(Timer - t0, "0.0 secs")

End Sub

CodePudding user response：

Conditionally Copy Entire Rows from Multiple Worksheets

Option Explicit

Sub CombineData()
    ' Source
    Const sBaseName As String = "A"
    Const sCol As String = "B"
    Const sfRow As Long = 2
    ' Destination
    Const dName As String = "Combined"
    Const dfCellAddress As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
    ' Clear previous data.
    Dim ddrg As Range
    Set ddrg = dfCell.Rows(1).Resize(dws.Rows.Count - dfCell.Row   1)
    ddrg.Clear
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim surg As Range
    Dim sCell As Range
    Dim slRow As Long
    
    For Each sws In wb.Worksheets
        ' When the worksheets start with 'sBaseName'. Improve if necessary.
        If InStr(1, sws.Name, sBaseName, vbTextCompare) = 1 Then
            slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
            If slRow >= sfRow Then
                Set srg = sws.Range(sws.Cells(sfRow, sCol), _
                    sws.Cells(slRow, sCol))
                For Each sCell In srg.Cells
                    If sCell.Value <> 0 Then
                        If surg Is Nothing Then ' first cell
                            Set surg = sCell
                        Else ' combine cells
                            Set surg = Union(surg, sCell)
                        End If
                    'Else ' cell value is 0
                    End If
                Next sCell
                 ' 'Union' works only on one worksheet.
                If Not surg Is Nothing Then
                    surg.EntireRow.Copy Destination:=dfCell
                    Set dfCell = dfCell.Offset(surg.Cells.Count)
                    Set surg = Nothing
                'Else ' no cell found
                End If
            'Else ' no data in worksheet
            End If
        'Else ' wrong worksheet
        End If
    Next sws
    
    MsgBox "Data combined.", vbInformation
    
End Sub