Reputation: 129
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
Upvotes: 2
Views: 374
Reputation: 16392
Use the comparison operator Like
Opton Explicit
Sub combine()
Const COPY_COLS = 22 ' B to W
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, "B").End(xlUp).Row
Set rngCmb = .Cells(lastrow + 1, "B")
End With
Application.ScreenUpdating = False
For Each ws In wb.Sheets
If ws.Name = "AC" Or Trim(ws.Name) Like "AC (*)" 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.Resize(1, COPY_COLS)
Set rngSelect = Union(rngSelect, c.Resize(1, COPY_COLS))
n = n + 1
End If
Next
' copy to combined
If n > 0 Then
rngSelect.Copy
rngCmb.PasteSpecial xlPasteValues
Set rngCmb = rngCmb.Offset(n)
Application.CutCopyMode = False
End If
msg = msg & vbLf & n & " rows from " & ws.Name
End With
Else
Debug.Print "Skipped '" & ws.Name & "'"
End If
Next
wsCmb.Select
Application.ScreenUpdating = True
MsgBox "Sheets combined " & msg, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Upvotes: 2
Reputation: 55073
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
Upvotes: 1