Copy ranges and specific cells into one worksheet

[asach1211]

Hello there,

I have been trying to play around with the VBA and realized that this code might be a little bit much for me. I need to copy different ranges from different sheets starting from one cell until it comes up empty. I would need the first range to copy to a specific cell into the master worksheet. The other ranges would need to copy underneath after the first range has completed copying I would need to do these for 6 sheets. Attached to these ranges I would need it to pull specific cells to paste to the next column dependent on these ranges.
Any help would be greatly appreciated!

I have attached a worksheet with comments to try to ease up confusion.

[stnkynts]

Here is my go at it:

Sub Populate_MasterSheet()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  Since there is some consistency in the ranges between the sheets
'  we can loop through each sheet and apply some logic to each range
'  within that sheet.  I will try to simplify it for you so that you
'  are able to see how the code works so that you can amend the code
'  later if needed.
'
'  -Stnkynts
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ws As Worksheet:   Set ws = Sheets("Master")
Dim wksht As Worksheet
Dim lMasterLR As Long, lwkshtLR1 As Long, lwkshtLR2 As Long
Dim strAccount As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False

For Each wksht In Worksheets
    If wksht.Name <> "Master" Then
        lMasterLR = ws.Range("D" & Rows.Count).End(xlUp).Row
        strAccount = wksht.Range("C8").Value
            If wksht.Range("B23").Value <> "" Then
                lwkshtLR1 = wksht.Range("B" & Rows.Count).End(xlUp).Row
                wksht.Range("B23:B" & lwkshtLR1).Copy Destination:=ws.Range("D" & lMasterLR).Offset(1, 0)
                ws.Range("E" & lMasterLR + 1).Value = strAccount
                ws.Range("E" & lMasterLR + 1, "E" & ws.Range("D" & Rows.Count).End(xlUp).Row).FillDown
            End If
            If wksht.Range("F23").Value <> "" Then
                lwkshtLR2 = wksht.Range("F" & Rows.Count).End(xlUp).Row
                wksht.Range("F23:F" & lwkshtLR2).Copy Destination:=ws.Range("K" & lMasterLR).Offset(1, 0)
            End If
    End If
Next wksht
                
Application.ScreenUpdating = True

Debug.Print "Procedure Completed Successfully"

Exit Sub

ErrHandler:
Debug.Print "There has been a critical error."
Application.ScreenUpdating = True

End Sub

[asach1211]

Also I tried it and THIS IS EXACTLY WHAT I WANTED! Just one thing though, is that if the range doesn't start at B23 or F23 then it wont pull the data.

[asach1211]

Thank you for taking a go at it, my only question is that some ranges start from B22 and F22 and some ranges start from B23 and F23 will this be able to differentiate?

[stnkynts]

Try this:

Sub Populate_MasterSheet()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  Since there is some consistency in the ranges between the sheets
'  we can loop through each sheet and apply some logic to each range
'  within that sheet.  I will try to simplify it for you so that you
'  are able to see how the code works so that you can amend the code
'  later if needed.
'
'  -Stnkynts
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ws As Worksheet:   Set ws = Sheets("Master")
Dim wksht As Worksheet
Dim lMasterLR As Long, lwkshtLR1 As Long, lwkshtLR2 As Long, startrow As Long
Dim strAccount As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False

For Each wksht In Worksheets
    If wksht.Name <> "Master" Then
        lMasterLR = ws.Range("D" & Rows.Count).End(xlUp).Row
        strAccount = wksht.Range("C8").Value
            startrow = 22
            Do
                startrow = startrow + 1
                Debug.Print startrow
            Loop Until wksht.Range("B" & startrow).Value <> ""
            
                lwkshtLR1 = wksht.Range("B" & Rows.Count).End(xlUp).Row
                lwkshtLR2 = wksht.Range("F" & Rows.Count).End(xlUp).Row
                wksht.Range("B" & startrow, "B" & lwkshtLR1).Copy Destination:=ws.Range("D" & lMasterLR).Offset(1, 0)
                ws.Range("E" & lMasterLR + 1).Value = strAccount
                ws.Range("E" & lMasterLR + 1, "E" & ws.Range("D" & Rows.Count).End(xlUp).Row).FillDown
                wksht.Range("F" & startrow, "F" & lwkshtLR2).Copy Destination:=ws.Range("K" & lMasterLR).Offset(1, 0)
    End If
Next wksht
                
Application.ScreenUpdating = True

Debug.Print "Procedure Completed Successfully"

Exit Sub

ErrHandler:
Debug.Print "There has been a critical error."
Application.ScreenUpdating = True

End Sub

[asach1211]

PERFECT! Is there anyway to have it pasted back as values? I realized I don't need to keep the formulas or formatting from the other sheets. By the way I really appreciate the help!

[stnkynts]

Like this:

Sub Populate_MasterSheet()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  Since there is some consistency in the ranges between the sheets
'  we can loop through each sheet and apply some logic to each range
'  within that sheet.  I will try to simplify it for you so that you
'  are able to see how the code works so that you can amend the code
'  later if needed.
'
'  -Stnkynts
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ws As Worksheet:   Set ws = Sheets("Master")
Dim wksht As Worksheet
Dim lMasterLR As Long, lwkshtLR1 As Long, lwkshtLR2 As Long, startrow As Long
Dim strAccount As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False

For Each wksht In Worksheets
    If wksht.Name <> "Master" Then
        lMasterLR = ws.Range("D" & Rows.Count).End(xlUp).Row
        strAccount = wksht.Range("C8").Value
            startrow = 22
            Do
                startrow = startrow + 1
                Debug.Print startrow
            Loop Until wksht.Range("B" & startrow).Value <> ""
            
                lwkshtLR1 = wksht.Range("B" & Rows.Count).End(xlUp).Row
                lwkshtLR2 = wksht.Range("F" & Rows.Count).End(xlUp).Row
                wksht.Range("B" & startrow, "B" & lwkshtLR1).Copy
                ws.Range("D" & lMasterLR).Offset(1, 0).PasteSpecial xlPasteValues
                ws.Range("E" & lMasterLR + 1).Value = strAccount
                ws.Range("E" & lMasterLR + 1, "E" & ws.Range("D" & Rows.Count).End(xlUp).Row).FillDown
                wksht.Range("F" & startrow, "F" & lwkshtLR2).Copy
                ws.Range("K" & lMasterLR).Offset(1, 0).PasteSpecial xlPasteValues
    End If
Next wksht
                
Application.CutCopyMode = False
Application.ScreenUpdating = True

Debug.Print "Procedure Completed Successfully"

Exit Sub

ErrHandler:
Debug.Print "There has been a critical error."
Application.ScreenUpdating = True

End Sub

[asach1211]

AWESOME it worked! Thank you!

[arlu1201]

Thread posted in CS forum.

Asach,

You are duplicating efforts by posting in both the paid forum (Commercial services) and in the free forum. Your thread in the paid forum is still open. What do you intend to do with it?