Copy specific columns after column contains BALANCES word in the header

[Hasson]

Hello
I would macro to deal with 2000 names in CLS sheet and 5000 rows for duplicates names in VB sheet.
in CLS sheet should show result in G:L after match NAME column between two sheets .
in VB sheet will contains duplicates names . so should merge amount for DEBIT,CREDIT columns when show in J,K columns in CLS sheet.
I don't want power query I don't used to use it , so I don't need it.

HS ‫‬.xlsx
	A	B	C
1	DATE	NAME	BALANCES
2	11/08/2024	AHHGGJ-1	5,100.00
3	12/09/2024	AHHGGJ-2	2,500.00
4	11/08/2024	AHHGGJ-3	28,200.00
5	11/09/2024	AHHGGJ-4	39,368.00
6	12/09/2024	AHHGGJ-5	2,370.00
7	TOTAL		77,538.00
CLS

Cell Formulas
Range	Formula
C7	C7	=SUM(C2:C6)

HS ‫‬.xlsx
	A	B	C	D	E	F
1	DATE	NAME	VMN	DEBIT	CREDIT	TOTAL
2	11/08/2024	AHHGGJ-1	REC	2,000.00		2,000.00
3	12/09/2024	AHHGGJ-2	PPA		1,200.00	-1,200.00
4	13/09/2024	AHHGGJ-2	REC	3,000.00		3,000.00
5	14/09/2024	AHHGGJ-1	REC	1,200.00		1,200.00
6	15/09/2024	AHHGGJ-2	PPA		100.00	-100.00
7	16/09/2024	AHHGGJ-3	REC	2,000.00		2,000.00
8	17/09/2024	AHHGGJ-4	REC	1,500.00		1,500.00
9	18/09/2024	AHHGGJ-5	REC	1,000.00		1,000.00
10	TOTAL			10,700.00	1,300.00	9,400.00
VB

Cell Formulas
Range	Formula
F2:F10	F2	=D2-E2
D10:E10	D10	=SUM(D2:D9)

I expect result like this

HS ‫‬.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L
1	DATE	NAME	BALANCES				DATE	NAME	BALANCES	DEBIT	CREDIT	TOTAL
2	11/08/2024	AHHGGJ-1	5,100.00				11/08/2024	AHHGGJ-1	5,100.00	3,200.00		8,300.00
3	12/09/2024	AHHGGJ-2	2,500.00				12/09/2024	AHHGGJ-2	2,500.00	3,000.00	1,300.00	4,200.00
4	11/08/2024	AHHGGJ-3	28,200.00				11/08/2024	AHHGGJ-3	28,200.00	2,000.00		30,200.00
5	11/09/2024	AHHGGJ-4	39,368.00				11/09/2024	AHHGGJ-4	39,368.00	1,500.00		40,868.00
6	12/09/2024	AHHGGJ-5	2,370.00				12/09/2024	AHHGGJ-5	2,370.00	1,000.00		3,370.00
7	TOTAL		77,538.00				TOTAL		77,538.00	10,700.00	1,300.00	86,938.00
CLS

Cell Formulas
Range	Formula
L2:L6	L2	=I2+J2-K2
C7,I7:L7	C7	=SUM(C2:C6)

thanks in advanced

 

[DanteAmor]

Try this:

Sub Create_Balance()
  'Variable declaration area
  Dim a As Variant, b As Variant, c As Variant
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim fec As Double, bal As Double
  Dim i As Long, y As Long
  
  Set sh1 = Sheets("CLS")
  Set sh2 = Sheets("VB")
  Set dic = CreateObject("Scripting.Dictionary")
  
  'Loading arrays
  a = sh1.Range("A2:C" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  b = sh2.Range("A2:F" & sh2.Range("A" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(a, 1), 1 To 6)
  
  'Create indexes
  For i = 1 To UBound(a)
    y = y + 1
    dic(a(i, 2)) = y
    c(y, 1) = a(i, 1)
    c(y, 2) = a(i, 2)
    c(y, 3) = a(i, 3)
  Next
  
  'Calculate balances
  For i = 1 To UBound(b)
    If dic.exists(b(i, 2)) Then
      y = dic(b(i, 2))
      c(y, 4) = c(y, 4) + b(i, 4)
      c(y, 5) = c(y, 5) + b(i, 5)
      c(y, 6) = c(y, 3) + c(y, 4) - c(y, 5)
    End If
  Next
  
  Application.ScreenUpdating = False
  'Pass values to the sheet
  sh1.Range("G2", sh1.Cells(Rows.Count, "L")).Clear
  With sh1.Range("G2").Resize(UBound(c, 1), UBound(c, 2))
    .Value = c
    .Borders.LineStyle = xlContinuous
  End With
  
  'Format cells
  sh1.Range("A" & Rows.Count).End(3).Copy
  sh1.Range("G" & Rows.Count).End(3).Resize(1, 6).PasteSpecial xlPasteFormats
  sh1.Range("G:L").HorizontalAlignment = xlCenter
  sh1.Range("I:L").NumberFormat = "#,##0.00;#,##0.00;"
  Application.ScreenUpdating = True
End Sub

 

[Hasson]

thanks, but the code doesn't show new name if there is new name in VB sheet and it's not existed in CLS .

 

[DanteAmor]

but the code doesn't show new name if there is new name in VB sheet and it's not existed in CLS .

In your example you did not put a case like that.
You also didn't explain it in your OP.


If you want that to happen, you will have to explain what those records that exist in VB and not CLS would be like and how you want the result.

 

[DanteAmor]

I will try to assume:

Sub Create_Balance()
  'Variable declaration area
  Dim a As Variant, b As Variant, c As Variant
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim fec As Double, bal As Double
  Dim i As Long, y As Long
  
  Set sh1 = Sheets("CLS")
  Set sh2 = Sheets("VB")
  Set dic = CreateObject("Scripting.Dictionary")
  
  'Loading arrays
  a = sh1.Range("A2:C" & sh1.Range("A" & Rows.Count).End(3).Row).Value
  b = sh2.Range("A2:F" & sh2.Range("A" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(a, 1) + UBound(a, 1), 1 To 6)
  
  'Create indexes
  For i = 1 To UBound(a) - 1
    y = y + 1
    dic(a(i, 2)) = y
    c(y, 1) = a(i, 1)
    c(y, 2) = a(i, 2)
    c(y, 3) = a(i, 3)
  Next
  For i = 1 To UBound(b) - 1
    If Not dic.exists(b(i, 2)) Then
      y = y + 1
      dic(b(i, 2)) = y
      c(y, 1) = b(i, 1)
      c(y, 2) = b(i, 2)
      c(y, 3) = 0
    End If
  Next
  i = UBound(a)
  y = dic.Count + 1
  dic(a(i, 2)) = y
  c(y, 1) = a(i, 1)
  c(y, 2) = a(i, 2)
  c(y, 3) = a(i, 3)
 
  'Calculate balances
  For i = 1 To UBound(b)
    If dic.exists(b(i, 2)) Then
      y = dic(b(i, 2))
      c(y, 4) = c(y, 4) + b(i, 4)
      c(y, 5) = c(y, 5) + b(i, 5)
      c(y, 6) = c(y, 3) + c(y, 4) - c(y, 5)
    End If
  Next
  
  Application.ScreenUpdating = False
  'Pass values to the sheet
  sh1.Range("G2", sh1.Cells(Rows.Count, "L")).Clear
  With sh1.Range("G2").Resize(dic.Count, UBound(c, 2))
    .Value = c
    .Borders.LineStyle = xlContinuous
  End With
  
  'Format cells
  sh1.Range("A" & Rows.Count).End(3).Copy
  sh1.Range("G" & Rows.Count).End(3).Resize(1, 6).PasteSpecial xlPasteFormats
  sh1.Range("G:L").HorizontalAlignment = xlCenter
  sh1.Range("I:L").NumberFormat = "#,##0.00;#,##0.00;"
  Application.ScreenUpdating = True
End Sub

 

[Hasson]

I will try to assume:

exactly this what I want it.
sorry about don't mention in OP !
thank you so much.