Need help setting up multiple sheets as source worksheets. Trying to loop through multiple sheets to consolidate data into a master sheet

[ccastro4]

Hi! I am new to VBA.

I currently have this code to help bring in data to a master sheet from another sheet with the same column header. Right now it only looks at one sheet (v6d). How do i get the code to look at the other 4 source worksheets to bring back the data into the master sheet? Code Below

Private Sub CommandButton1_Click()

Dim sourceWS As Worksheet, targetWS As Worksheet
Dim lastCol As Long, lastRow As Long, srcRow As Range
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String


Set sourceWS = Worksheets("V6D")
Set targetWS = Worksheets("ADP Data")


With sourceWS
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To lastCol
Cr1 = .Cells(1, j).Value
Set srcRow = .Range("A1", .Cells(1, lastCol))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

If Not found1 Is Nothing Then
lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=False)

If Not found2 Is Nothing Then
lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
found2.Offset(1, 0).PasteSpecial xlPasteAll
End If

End If

Next j

End With


End Sub

 

[jolivanes]

How far does this get you?
For the first problem, if you change this

.Cells(2, cel.Column).Resize(lr - 1).Copy sh1.Cells(sh1.Rows.Count, i).End(xlUp).Offset(1)

to this

.Cells(2, cel.Column).Resize(lr - 1).Copy sh1.Cells(sh1.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1, i)

does that help?

 

[ccastro4]

Weird - I used the code i sent you and its not working fully. Stopped populating after 3rd column. When i edited the code to your suggestion, It started the data for the next column on the next row where data ended on previous column, causing a staggered effect up until 3rd column. However, when i look at current macro i am running, i see below. Not sure where i pulled the one i sent from?


Either way - this should be the code I am running. Sorry about that! Hopefully, its an easy edit from here?

Sub Maybe()
Dim wsArr, ws1 As Worksheet, i As Long, j As Long
wsArr = Array("RBD", "ADX", "FL4", "QY2", "V6D")
Set ws1 = Worksheets("ADP Data")
    For i = 1 To ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
        For j = LBound(wsArr) To UBound(wsArr)
            With Worksheets(wsArr(j))
        On Error Resume Next
                    .UsedRange.Columns(.Rows(1).Find(ws1.Cells(1, i)).Column).Offset(1).Copy ws1.Cells(Rows.Count, i).End(xlUp).Offset(1)
        On Error GoTo 0
            End With
        Next j
    Next i
End Sub

 

[jolivanes]

Use the code from Post #17 after making the changes suggested in Post #21.
Delete all the older macros.

 

[ccastro4]

thank you. It's populating the data in a staggering effect. Column B should line up with column A.

The data also stopped being pulled at 4th column, last name. No more data populated after that for all the other columns

Sub Maybe_2()
Dim sh1 As Worksheet, wsArr, i As Long, j As Long, cel As Range, lr As Long
Set sh1 = Worksheets("ADP Data")
wsArr = Array("RBD", "ADX", "FL4", "QY2", "V6D")
    For i = 1 To 4
        For j = LBound(wsArr) To UBound(wsArr)
            With Worksheets(wsArr(j))
                Set cel = .Rows(1).Find(sh1.Cells(1, i).Value)
                    If Not cel Is Nothing Then
                        lr = .Cells(.Rows.Count, cel.Column).End(xlUp).Row
                        .Cells(2, cel.Column).Resize(lr - 1).Copy sh1.Cells(sh1.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1, i)
                    End If
            End With
        Next j
    Next i
End Sub

 

[jolivanes]

I thought that this "we need the data being pulled in to match the corresponding rows from the other columns" meant that the data needed to be pasted where it does now.

Use DropBox or a similar site to attach an example workbook with a before and after as well as an explanation on how you got to the after. No personal data like names, email addresses etc.

 

[ccastro4]

I thought that this "we need the data being pulled in to match the corresponding rows from the other columns" meant that the data needed to be pasted where it does now.

Use DropBox or a similar site to attach an example workbook with a before and after as well as an explanation on how you got to the after. No personal data like names, email addresses etc.

I provided a screen shot of what i think should help explain. If not, ill try uploading example work book via drop box over the weekend. Are you over me yet? I hope not! I told my boss you are my forum friend and i dont even know if you are a man or a woman!

Also, With the code i am supposed to use, i think i know why only 4 columns of data gets transferred over from the sheets into summary sheet. Its because of the line For i = 1 To 4. I tried changing this to For i = 1 To 173 because that is how many columns there are but it times out. Any adjustments i can make here.? I looked at old code and it has this For i = 1 To ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column but i ran into an error when i tried changing it

Sub Maybe_2()
Dim sh1 As Worksheet, wsArr, i As Long, j As Long, cel As Range, lr As Long
Set sh1 = Worksheets("ADP Data")
wsArr = Array("RBD", "ADX", "FL4", "QY2", "V6D")
    For i = 1 To 4
        For j = LBound(wsArr) To UBound(wsArr)
            With Worksheets(wsArr(j))
                Set cel = .Rows(1).Find(sh1.Cells(1, i).Value)
                    If Not cel Is Nothing Then
                        lr = .Cells(.Rows.Count, cel.Column).End(xlUp).Row
                        .Cells(2, cel.Column).Resize(lr - 1).Copy sh1.Cells(sh1.Rows.Count, i).End(xlUp).Offset(1)
                    End If
            End With
        Next j
    Next i
End Sub