VBA to loop through worksheets with sheet names in cells

[Godwin117]

I have this excel worksheet that I'm trying automate most of what I'm doing however I feel this is a little too advanced for me. I have the sheet names in cells(B2:B61). It will copy and paste data from D:I with the row that the sheet name is in and at the bottom of that sheet after the last row with data it will paste the copied data. An example is below. The main worksheet is called "Main".

On worksheet "Main" B2 is "MTP" the data is from D2:I2. Copy D2:I2 and go to worksheet("MTP") and paste underneath the previous data ("A"&lastrow). Go back to worksheet("Main"). B3 is "RENN" the data is from D3:I3. Copy D3:I3 and go to worksheet("RENN") and paste underneath the previous data ("A"&lastrow). Loop through all worksheets(B2:B61). Once complete Worksheet("Main").Select. Hopefully, this spells out what I'm looking for and any help would be greatly appreciated.

 

[vcoolio]

BTW Godwin,

The code in post #2, modified a little as follows, will work as well:-

Option Explicit
Sub Test()

        Dim ar As Variant, i As Long
        Dim wsM As Worksheet, wsA As Worksheet
        Set wsM = Sheets("Main")
        ar = wsM.Range("B2", wsM.Range("B" & wsM.Rows.Count).End(xlUp))
        
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

        For i = 1 To UBound(ar)
           Set wsA = Sheets(CStr(ar(i, 1)))
                With wsM.[A1].CurrentRegion
                        .AutoFilter 2, ar(i, 1)
                        .Columns("D:H").Offset(1).Copy wsA.Range("A" & Rows.Count).End(3)(2)
                        .Columns("I").Offset(1).Copy wsA.Range("G" & Rows.Count).End(3)(2)
                        .AutoFilter
                End With
                
                wsA.Columns.AutoFit
        Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Cheerio,
vcoolio.

 

[Godwin117]

Hello Godwin,

Two things that you must do first:-
1) Unhide Columns A and B in the "Main" sheet.
2) Place headings in A1 and B1, even if it just a single letter.

Following are two codes which will do the task for you. The second code is some 20%-30% faster and may suit you better:-

Option Explicit

Sub TransferData()

            Dim i As Long, x As Long, nrow As Long
            Dim clArr As Variant: clArr = Array(4, 5, 6, 7, 8, 9)
            Dim pArr As Variant: pArr = Array("A", "B", "C", "D", "E", "G")
            Dim wsM As Worksheet: Set wsM = Sheets("Main")
            Dim ar As Variant: ar = wsM.Range("B2", wsM.Range("B" & wsM.Rows.Count).End(xlUp))

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

            For i = 1 To UBound(ar)
                    nrow = Sheets(ar(i, 1)).Cells(Rows.Count, 1).End(xlUp).Row + 1
                    For x = LBound(clArr) To UBound(clArr)
                            With wsM.[A1].CurrentRegion
                                    .AutoFilter 2, ar(i, 1)
                                    .Columns(clArr(x)).Offset(1).Copy Sheets(ar(i, 1)).Range(pArr(x) & nrow)
                                    .AutoFilter
                            End With
                    Next x
            Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Option Explicit
Sub TransferData2()

            Dim Data, Dict As Object, i As Long
            Dim wsM As Worksheet: Set wsM = Sheets("Main")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

            Set Dict = CreateObject("Scripting.Dictionary")
            With wsM.Cells(1).CurrentRegion
                    Data = .Value
                    For i = 2 To UBound(Data)
                                If Data(i, 2) <> "" Then
                                If Not Dict.exists(Data(i, 2)) Then
                                Dict.Add Data(i, 2), 1
                                .AutoFilter 2, Data(i, 2)
                                With .Offset(1)
                                        .Columns("D:H").Copy Sheets(Data(i, 2)).Range("A" & Rows.Count).End(3)(2)
                                        .Columns("I").Copy Sheets(Data(i, 2)).Range("G" & Rows.Count).End(3)(2)
                                End With
                                .AutoFilter
                                End If
                          End If
                    Next i
            End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Both codes have been tested in the sample workbook that you supplied and both work well.

Please note that the second code is not my work. A fellow Volunteer (Sintek), who only visits another forum solely, took interest in your query and, through me, offered up the code for you to test with.

I hope that this helps.

Cheerio,
vcoolio.

Thank you those worked perfectly.

 

[vcoolio]

You're welcome Godwin. Glad to have been able to assist.

I'll pass your thanks on to Sintek as well.

Cheerio,
vcoolio.