VBA copy worksheets into one if a condition is met

[sagarshah]

Hello,

VBA to merge two worksheets into a new worksheet based on criteria.

Input Sheets : APA, BANK, GA
Output Sheets: APA PAYMENT & GA PAYMENT

I want to do the following:

• Copy all data from APA sheet and paste to APA Payment
• Copy data that contains "APA" in Column B from BANK sheet and paste to APA Payment
• APA Payment Sort by date and add a subtotal

and...

• Copy all data from GA sheet and paste to GA Payment
• Copy data that contains "GA" in Column B from BANK sheet and paste to GA Payment
• GA Payment Sort by date and add a subtotal

See example tables below :

INPUT SHEET : APA
[TABLE="width: 500"]
<tbody>[TR]
[TD]NUMBER[/TD]
[TD]DATE[/TD]
[TD]CLIENT[/TD]
[TD]DEBIT[/TD]
[TD]CREDIT[/TD]
[TD]DESC[/TD]
[TD]SHEETNAME[/TD]
[/TR]
[TR]
[TD]CH1[/TD]
[TD]1/9/19[/TD]
[TD]CUST1[/TD]
[TD]1000[/TD]
[TD][/TD]
[TD]T1[/TD]
[TD]APA[/TD]
[/TR]
[TR]
[TD]CH2[/TD]
[TD]2/9/19[/TD]
[TD]CUST2[/TD]
[TD]2000[/TD]
[TD][/TD]
[TD]T2[/TD]
[TD]APA[/TD]
[/TR]
</tbody>[/TABLE]


INPUT SHEET : GA
[TABLE="width: 500"]
<tbody>[TR]
[TD]NUMBER[/TD]
[TD]DATE[/TD]
[TD]CLIENT[/TD]
[TD]DEBIT[/TD]
[TD]CREDIT[/TD]
[TD]DESC[/TD]
[TD]SHEETNAME[/TD]
[/TR]
[TR]
[TD]CH100[/TD]
[TD]3/9/19[/TD]
[TD]CUST10[/TD]
[TD]5000[/TD]
[TD][/TD]
[TD]T10[/TD]
[TD]GA[/TD]
[/TR]
[TR]
[TD]CH101[/TD]
[TD]4/9/19[/TD]
[TD]CUST11[/TD]
[TD]6000[/TD]
[TD][/TD]
[TD]T11[/TD]
[TD]GA[/TD]
[/TR]
</tbody>[/TABLE]


INPUT SHEET : BANK
[TABLE="width: 500"]
<tbody>[TR]
[TD]CHQ[/TD]
[TD]DATE[/TD]
[TD]CLIENT[/TD]
[TD]DEBIT[/TD]
[TD]CREDIT[/TD]
[TD]DESC[/TD]
[TD]SHEETNAME[/TD]
[/TR]
[TR]
[TD]BK1[/TD]
[TD]5/9/19[/TD]
[TD]APA[/TD]
[TD][/TD]
[TD]1000[/TD]
[TD]CUST1[/TD]
[TD]BANK[/TD]
[/TR]
[TR]
[TD]BK2[/TD]
[TD]6/9/19[/TD]
[TD]APA[/TD]
[TD][/TD]
[TD]2000[/TD]
[TD]CUST2[/TD]
[TD]BANK[/TD]
[/TR]
[TR]
[TD]BK3[/TD]
[TD]6/9/19[/TD]
[TD]GA[/TD]
[TD][/TD]
[TD]5000[/TD]
[TD]CUST10[/TD]
[TD]BANK[/TD]
[/TR]
</tbody>[/TABLE]



OUTPUT SHEET : APA PAYMENT (vba code)
[TABLE="width: 500"]
<tbody>[TR]
[TD]INV[/TD]
[TD]DATE[/TD]
[TD]CLIENT[/TD]
[TD]DEBIT[/TD]
[TD]CREDIT[/TD]
[TD]DESC[/TD]
[TD]SHEETNAME[/TD]
[/TR]
[TR]
[TD]CH1[/TD]
[TD]1/9/19[/TD]
[TD]CUST1[/TD]
[TD]1000[/TD]
[TD][/TD]
[TD]T1[/TD]
[TD]APA PAYMENT[/TD]
[/TR]
[TR]
[TD]CH2[/TD]
[TD]2/9/19[/TD]
[TD]CUST2[/TD]
[TD]2000[/TD]
[TD][/TD]
[TD]T2[/TD]
[TD]APA PAYMENT[/TD]
[/TR]
[TR]
[TD]BK1[/TD]
[TD]5/9/19[/TD]
[TD]APA[/TD]
[TD][/TD]
[TD]1000[/TD]
[TD]CUST1[/TD]
[TD]APA PAYMENT[/TD]
[/TR]
[TR]
[TD]bk2[/TD]
[TD]6/9/19[/TD]
[TD]APA[/TD]
[TD][/TD]
[TD]2000[/TD]
[TD]CUST2[/TD]
[TD]APA PAYMENT[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]TOTAL[/TD]
[TD]3000[/TD]
[TD]3000[/TD]
[TD][/TD]
[TD]APA PAYMENT[/TD]
[/TR]
</tbody>[/TABLE]


OUTPUT SHEET : GA PAYMENT (vba code)
[TABLE="width: 500"]
<tbody>[TR]
[TD]INV[/TD]
[TD]DATE[/TD]
[TD]CLIENT[/TD]
[TD]DEBIT[/TD]
[TD]CREDIT[/TD]
[TD]DESC[/TD]
[TD]SHEETNAME[/TD]
[/TR]
[TR]
[TD]CH100[/TD]
[TD]3/9/19[/TD]
[TD]CUST10[/TD]
[TD]5000[/TD]
[TD][/TD]
[TD]T10[/TD]
[TD]GA PAYMENT[/TD]
[/TR]
[TR]
[TD]CH101[/TD]
[TD]2/9/19[/TD]
[TD]CUST11[/TD]
[TD]6000[/TD]
[TD][/TD]
[TD]T11[/TD]
[TD]GA PAYMENT[/TD]
[/TR]
[TR]
[TD]BK3[/TD]
[TD]6/9/19[/TD]
[TD]GA[/TD]
[TD][/TD]
[TD]5000[/TD]
[TD]CUST10[/TD]
[TD]GA PAYMENT[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]TOTAL[/TD]
[TD]11000[/TD]
[TD]5000[/TD]
[TD][/TD]
[TD]GA PAYMENT

[/TD]
[/TR]
</tbody>[/TABLE]


Thanks in advance.

 

[GirishDhruva]

Hi i am not a coder but i tried.
try with the below code.

And if anyone in the forum could simplify this code.
Please do.

Option Explicit


Sub sagarshah()
Dim lrow, lrow1, lrow2 As Long
Dim i As Integer
Dim ws, ws1 As Worksheet


Worksheets.Add
ActiveSheet.Name = "APA_PAYMENT"
Set ws = Worksheets("APA_PAYMENT")
Worksheets("APA").Activate
Worksheets("APA").UsedRange.Select
Selection.Copy
Worksheets("APA_PAYMENT").Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False


With Worksheets("BANK")
    lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = lrow To 2 Step -1
        If .Cells(i, 3).Text = "APA" Then
            .Rows(i).Copy
            With Worksheets("APA_PAYMENT")
                lrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
                .Range("A" & lrow1 + 1).PasteSpecial
            End With
        End If
    Next i
End With
With ws.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=ws.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange ws.Range("B2:B" & lrow1)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Application.CutCopyMode = False
Worksheets("APA_PAYMENT").Activate
lrow1 = Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To 5
    Cells(lrow1 + 1, i).Formula = "=SUM(" & Range(Cells(1, i), Cells(lrow1, i)).Address & ")"
Next


Worksheets.Add
ActiveSheet.Name = "GA_PAYMENT"
Set ws1 = Worksheets("GA_PAYMENT")
Worksheets("GA").Activate
Worksheets("GA").UsedRange.Select
Selection.Copy
Worksheets("GA_PAYMENT").Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False


With Worksheets("BANK")
    lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = lrow To 2 Step -1
        If .Cells(i, 3).Text = "GA" Then
            .Rows(i).Copy
            With Worksheets("GA_PAYMENT")
                lrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
                .Range("A" & lrow1 + 1).PasteSpecial
            End With
        End If
    Next i
End With
With ws.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=ws.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange ws.Range("B2:B" & lrow1)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Application.CutCopyMode = False
Worksheets("GA_PAYMENT").Activate
lrow1 = Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To 5
    Cells(lrow1 + 1, i).Formula = "=SUM(" & Range(Cells(1, i), Cells(lrow1, i)).Address & ")"
Next
End Sub

Regards,
Dhruva.