VBA to split a report to 5 worksheets different criteria with loops

[Number1One]

Hi All,

New to VBA/Macros trying to learn whilst piecing together examples i've seen, think what i've got works but is long winded and needs a different macro for each split and will require tweaking if/as the report changes.

Im trying to break out a report in 1 worksheet into 5 different worksheets all with different criteria with no blank rows.

1 Report info:
Has 1 match column in A and row 1 to pull data in from another workbook.
Rows 4 to 24 are Header/Totals/ product info etc
Row 25 on wards is data

All split worksheets wants columns:
E, F, G,K*,N Then a variety of O,P,Q,R,S,T,U depending on which worksheet it is.
*K is a value given in the VBA depending on Worksheet

WS 1 only wants rows where Column:
G="NH" and J="BF"

WS 2 only wants rows where Column:
G="H" and J="BF"

WS 3 only wants rows where Column:
H<>"WB" and J="BF"

WS 4 only wants rows where Column:
H="WB" and J="BF"

WS only wants rows where Column:
J="LY"

Thanks for any help.
Here is the example i currently have for WS1:

Sub NH() Dim ds As Worksheet
Dim dr As Worksheet

Set ds = ThisWorkbook.Sheets("All")
Set dr = ThisWorkbook.Sheets("NH")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'last row db sheet, last row report sheet
dLR = ds.Cells(Rows.Count, 1).End(xlUp).Row
drLR = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1

'clear last report
dr.Range("A1:M" & drLR).ClearContents

y = 4
'loop through db
For x = 4 To dLR
If IsEmpty(ds.Cells(x, 2)) Or ds.Cells(x, 2) = "Count" Then
'add to report sheet
dr.Cells(y, 1) = ds.Cells(x, 5)
dr.Cells(y, 2) = ds.Cells(x, 6)
dr.Cells(y, 3) = ds.Cells(x, 7)
dr.Cells(y, 4) = ds.Cells(x, 11)
dr.Cells(y, 5) = ds.Cells(x, 14)
dr.Cells(y, 6) = ds.Cells(x, 15)
y = y + 1
End If

Next x

'starting row report sheet
y = 25

'loop through db
For x = 25 To dLR
If ds.Cells(x, 7) = "NH" And ds.Cells(x, 10) = "BF" Then
'add to report sheet
dr.Cells(y, 1) = ds.Cells(x, 5)
dr.Cells(y, 2) = ds.Cells(x, 6)
dr.Cells(y, 3) = "L3"
dr.Cells(y, 4) = ds.Cells(x, 11)
dr.Cells(y, 5) = ds.Cells(x, 14)
dr.Cells(y, 6) = ds.Cells(x, 15)
y = y + 1
End If

Next x

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

End Sub

 

[shknbk2]

I'm not sure if this is a start for what you are looking for. It's hard to know if the code can be shortened a bit until I know more about what you want to do and if this code is close or not.

Anyway, take a look and see if this is what you were thinking. You need to change the code to add the correct names for your report sheets in the array.

I'm not sure why you set the Calculation again to xlCalculationManual at the end of your code, but I kept it in. Change it if you wanted to change it back to xlCalculationAutomatic.

Sub splitReport()
    Dim ds As Worksheet
    Dim dr As Worksheet
    Dim shArray As Variant
    Dim i As Integer
    
    'change the wsNames to the actual names of your worksheets (for example, "NH" instead of "ws1Name")
    shArray = Split("ws1Name,ws2Name,ws3Name,ws4Name,ws5Name", ",")
    
    Set ds = ThisWorkbook.Sheets("All")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    'last row db sheet, last row report sheet
    dLR = ds.Cells(Rows.Count, 1).End(xlUp).Row
    
    'clear last report
    For i = 0 To UBound(shArray)
        Set dr = ThisWorkbook.Sheets(shArray(i))
        dr.Range("A1:M" & dr.Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
    Next i
    
    y = 4
    'loop through db
    For x = 4 To dLR
        If IsEmpty(ds.Cells(x, 2)) Or ds.Cells(x, 2) = "Count" Then
            'add to report sheets
            For i = 0 To UBound(shArray)
                Set dr = ThisWorkbook.Sheets(shArray(i))
                dr.Cells(y, 1) = ds.Cells(x, 5)
                dr.Cells(y, 2) = ds.Cells(x, 6)
                dr.Cells(y, 3) = ds.Cells(x, 7)
                dr.Cells(y, 4) = ds.Cells(x, 11)
                dr.Cells(y, 5) = ds.Cells(x, 14)
                dr.Cells(y, 6) = ds.Cells(x, 15)
            Next i
            y = y + 1
        End If
    Next x
    
    'starting row report sheet
    'y = 25
    
    'loop through db
    For x = 25 To dLR
        'ws1
        If ds.Cells(x, 7) = "NH" And ds.Cells(x, 10) = "BF" Then
            'add to report sheet
            Set dr = ThisWorkbook.Sheets(0)
            y = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If y < 25 Then
                y = 25
            End If
            dr.Cells(y, 1) = ds.Cells(x, 5)
            dr.Cells(y, 2) = ds.Cells(x, 6)
            dr.Cells(y, 3) = "L3"
            dr.Cells(y, 4) = ds.Cells(x, 11)
            dr.Cells(y, 5) = ds.Cells(x, 14)
            dr.Cells(y, 6) = ds.Cells(x, 15)
        'ws2
        ElseIf ds.Cells(x, 7) = "H" And ds.Cells(x, 10) = "BF" Then
            'add to report sheet
            Set dr = ThisWorkbook.Sheets(1)
            y = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If y < 25 Then
                y = 25
            End If
            dr.Cells(y, 1) = ds.Cells(x, 5)
            dr.Cells(y, 2) = ds.Cells(x, 6)
            dr.Cells(y, 3) = "L3"
            dr.Cells(y, 4) = ds.Cells(x, 11)
            dr.Cells(y, 5) = ds.Cells(x, 14)
            dr.Cells(y, 6) = ds.Cells(x, 15)
        'ws3
        ElseIf ds.Cells(x, 8) <> "WB" And ds.Cells(x, 10) = "BF" Then
            'add to report sheet
            Set dr = ThisWorkbook.Sheets(2)
            y = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If y < 25 Then
                y = 25
            End If
            dr.Cells(y, 1) = ds.Cells(x, 5)
            dr.Cells(y, 2) = ds.Cells(x, 6)
            dr.Cells(y, 3) = "L3"
            dr.Cells(y, 4) = ds.Cells(x, 11)
            dr.Cells(y, 5) = ds.Cells(x, 14)
            dr.Cells(y, 6) = ds.Cells(x, 15)
        'ws4
        ElseIf ds.Cells(x, 8) = "WB" And ds.Cells(x, 10) = "BF" Then
            'add to report sheet
            Set dr = ThisWorkbook.Sheets(3)
            y = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If y < 25 Then
                y = 25
            End If
            dr.Cells(y, 1) = ds.Cells(x, 5)
            dr.Cells(y, 2) = ds.Cells(x, 6)
            dr.Cells(y, 3) = "L3"
            dr.Cells(y, 4) = ds.Cells(x, 11)
            dr.Cells(y, 5) = ds.Cells(x, 14)
            dr.Cells(y, 6) = ds.Cells(x, 15)
        'ws5
        ElseIf ds.Cells(x, 10) = "LY" Then
            'add to report sheet
            Set dr = ThisWorkbook.Sheets(4)
            y = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1
            If y < 25 Then
                y = 25
            End If
            dr.Cells(y, 1) = ds.Cells(x, 5)
            dr.Cells(y, 2) = ds.Cells(x, 6)
            dr.Cells(y, 3) = "L3"
            dr.Cells(y, 4) = ds.Cells(x, 11)
            dr.Cells(y, 5) = ds.Cells(x, 14)
            dr.Cells(y, 6) = ds.Cells(x, 15)
        End If
    Next x
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
End Sub

 

[Number1One]

Cheers for the feedback Shknbk2.

ManualCal, haha yes i did have it setting back to Automatic, and then change it to Manual hence why its still there.

I was hoping to have 1 instead of 2 sections for the y=4 and y=25 parts. y=4 part is just headings etc but doesn't have a the same reference for the IF's as the data does. but needs to pull in only the right columns that match the ones in the data section y=25.

'shArray = Split' ive changed to 'shArray = VBA.split' otherwise it had an error
Getting an error on 'Set ds = ThisWorkbook.Sheets("All")' error message subscript out of range

 

[Number1One]

Managed to get something that works for me, wanted to share in the hope it may help someone, still a little long winded but does what i want. The below splits into 1 worksheet there is another with small changes splitting our to 2nd, 3rd etc and a button that runs them all.

Sub NH()
Dim ds As Worksheet
Dim dr As Worksheet


Set ds = ThisWorkbook.Sheets("Allocation")
Set dr = ThisWorkbook.Sheets("NH")




Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual




'last row db sheet, last row report sheet
dLR = ds.Cells(Rows.Count, 1).End(xlUp).Row
drLR = dr.Cells(Rows.Count, 1).End(xlUp).Row + 1




'clear last report
dr.Range("A1:M" & drLR).ClearContents


'starting row report sheet
y = 4
Z = 24
'loop through db


For x = 2 To dLR
If (ds.Cells(x, 7) = "NH" And ds.Cells(x, 10) = "BF" And Application.Sum(ds.Cells(x, 15)) > 0) Or (x < 25 And x > 3) Then
'add to report sheet
dr.Cells(y, 1) = ds.Cells(x, 5)
dr.Cells(y, 2) = ds.Cells(x, 6)
dr.Cells(Z, 3) = "KFCL3"
dr.Cells(y, 4) = ds.Cells(x, 11)
dr.Cells(y, 5) = ds.Cells(x, 14)
dr.Cells(y, 6) = ds.Cells(x, 15)
y = y + 1
Z = Z + 1
End If

Next x


Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual


End Sub