According to your attachment a VBA demonstration for starters :
PHP Code:
Sub Demo1() Const C = "<>0" Dim Rg(1) As Range, R&, S%, W, V(1 To 3) Set Rg(0) = [Results!B4] Rg(0).CurrentRegion.Offset(1).Clear R = 2 For S = 1 To 2 With Sheets(S) Set Rg(1) = .UsedRange.Find("Data", , xlValues, 1, 1): If Rg(1) Is Nothing Then Erase Rg: Beep: Exit Sub W = Application.Match("Amount", .Rows(Rg(1).Row), 0): If IsError(W) Then Erase Rg: Beep: Exit Sub With .Range(Rg(1)(2), Rg(1).End(xlDown)) V(S) = "=SUMIF(" & .Address(, , , True) & ",B5," & .Columns(W + 1 - Rg(1).Column).Address(, , , True) & ")" .Copy Rg(0)(R) R = R + .Count End With End With Next Rg(0).CurrentRegion.Columns(1).RemoveDuplicates 1, 1 V(3) = "=C5-D5" With Rg(0).CurrentRegion.Rows .Item("2:" & .Count).Columns("B:D").Formula = V If Application.CountIf(.Columns(4), C) - 1 Then .Columns(4).AutoFilter 1, C .Item("2:" & .Count).Interior.Color = vbYellow .AutoFilter End If With .Item(.Count + 1).Columns("B:D") .Borders(8).Weight = 2 .Formula = "=SUM(C5:C" & .Row - 1 & ")" End With End With Erase Rg End Sub
► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄
Hello Marc L
Thank you so much for your help. The code is working fine on test data shared. As mentioned in sample work book I was expected, to select the colum range manually. Instead of finding "data" and "amount". And sheet names also not fixed one.
But your method also good. But I need to use this code to multiple workbooks., so can you please help to change the code little bit as per my revised sample work book.
Sub Demo1r() Const C = "<>0" Dim Rg(2) As Range, S%, R&, V(1 To 3) Set Rg(0) = [Results!B4] Rg(0).Parent.UsedRange.Clear For S = 1 To 2 Sheets(S).Activate On Error Resume Next Do Set Rg(1) = Application.InputBox(" Select names column :", "Sheet #" & S, Type:=8) If Err.Number Then Erase Rg: Exit Sub Loop Until Rg(1).Areas.Count = 1 And Rg(1).Columns.Count = 1 And Not IsEmpty(Rg(1)(2)) On Error GoTo 0 If Rg(1).Count = 1 Then Set Rg(1) = Range(Rg(1), Rg(1).End(xlDown)) If S = 1 Then Rg(1).Copy Rg(0) R = Rg(1).Count + 1 Else Rg(1).Rows("2:" & Rg(1).Rows.Count).Copy Rg(0)(R) If Rg(1)(1).Text <> Rg(0).Text Then Rg(0).Value2 = Rg(0).Text & "/" & Rg(1)(1).Text End If Rg(0)(1, S + 1).Value2 = Rg(1).Parent.Name Rg(1).Parent.Activate On Error Resume Next Do Set Rg(2) = Application.InputBox(" Select values column :", "Sheet #" & S, Type:=8) If Err.Number Then Erase Rg: Exit Sub If Rg(2).Count = 1 And Not IsEmpty(Rg(2)(2)) Then Set Rg(2) = Range(Rg(2), Rg(2).End(xlDown)) Loop Until Rg(2).Areas.Count = 1 And Rg(2).Columns.Count = 1 And _ Rg(2).Parent.Name = Rg(1).Parent.Name And Rg(2).Rows.Count = Rg(1).Rows.Count On Error GoTo 0 V(S) = "=SUMIF(" & Rg(1).Address(, , , True) & ",B5," & Rg(2).Address(, , , True) & ")" Next Rg(0).CurrentRegion.Columns(1).RemoveDuplicates 1, 1 Rg(0)(1, 4).Value2 = "GAP" V(3) = "=C5-D5" With Rg(0).CurrentRegion.Rows .Item("2:" & .Count).Columns("B:D").Formula = V If Application.CountIf(.Columns(4), C) - 1 Then .Columns(4).AutoFilter 1, C .Item("2:" & .Count).Interior.Color = vbYellow .AutoFilter End If With .Item(.Count + 1).Columns("B:D") .Borders(8).Weight = 2 .Formula = "=SUM(C5:C" & .Row - 1 & ")" End With .Parent.Activate End With Erase Rg End Sub
► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄
Last edited by Marc L; 03-18-2022 at 10:13 PM.
Reason: optimization …
Bookmarks