Macro to merging for multiple columns contain same headers

Maklil · Jan 14, 2025

Hi Guys,
I search for macro to deal with about 15000 rows for SUMMARY sheet.
so in FINAL
FINAL sheet will be result with formatting and borders.
in SUMMARY sheet should merge amounts (D:G) are existed in the same column based on name and sheet name in columns B:C
the headers in row1 will transfer as column in C column and repeat it for each name in column B is relating with the header in row1
also insert two rows to the bottom TOTAL ,NET to calculation.
as to sorting data should be from A-Z based n column B .
should delete data in FINAL sheet before show report.
so the data in SUMMARY sheet.

mk1.xlsm

A

B

C

D

E

F

G

H

I

J

1

MK

MT

MS

ATS

2

DATE

NAME

PAID

NOT PAID

RECEIVED

NOT REICEVED

RECEIVED

NOT REICEVED

PAID

NOT PAID

3

20/08/2023

MVS

6,800.00

-

2,800.00

-

340.00

345.00

-

4

20/08/2023

MVS

10,000.00

-

5

21/08/2023

MVS

-

19,600.00

1000

-

655.00

-

6

21/08/2023

MVS

-

4,750.00

7

21/08/2023

MSS

-

11,580.00

-

495.00

-

8

21/08/2023

MTT

-

1,950.00

-

9

21/08/2023

MLL

10,000.00

-

3,470.00

-

10

24/08/2023

MKK

-

84,400.00

-

1,245.00

11

24/08/2023

MLL

10,000.00

-

3,960.00

-

12

25/08/2023

MKK

12,000.00

-

460.00

-

13

25/08/2023

MSS

-

100

-

200

640.00

-

14

25/08/2023

MLL

-

1000

-

950.00

-

15

25/08/2023

MKK

1,000.00

-

1000

-

450.00

-

16

TOTAL

17

NET

38,895.00

SUMMARY

Cell Formulas
Range	Formula
C16:J16	C16	=SUM(C3:C15)
J17	J17	=(E16+G16)-(C16+I16)

mk1.xlsm

A

B

C

D

E

F

G

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

FINAL

the output should be

mk1.xlsm

A

B

C

D

E

F

G

1

ITEM

NAME

Sheet name

PAID

NOT PAID

RECEIVED

NOT REICEVED

2

1

MKK

MK

13,000.00

-

3

2

MKK

MT

-

85,400.00

-

4

3

MKK

ATS

910.00

-

5

4

MKK

ATS

-

1,245.00

-

6

5

MKK

MT

-

1,000.00

7

6

MLL

MK

20,000.00

-

8

7

MLL

MT

-

1,000.00

-

9

8

MLL

MT

-

7,430.00

10

9

MLL

ATS

950.00

-

11

10

MTT

MT

-

1,950.00

12

11

MVS

MK

16,800.00

24,350.00

-

13

12

MVS

MT

-

3,800.00

-

14

13

MVS

MS

-

345.00

15

14

MVS

MS

-

995

-

16

15

MSS

MK

-

11,680.00

-

17

16

MSS

MS

-

695.00

18

17

MSS

ATS

640.00

-

19

TOTAL

20

NET

38,895.00

FINAL

Cell Formulas
Range	Formula
D19:G19	D19	=SUM(D2:D18)
G20	G20	=F19-D19

by the way I don't want power query or pivot table, just macro to deal data .
thanks

DanteAmor · Jan 14, 2025

I think some values in your output example are not grouped in the correct row:

This is what I get as a result

Dante Amor

A

B

C

D

E

F

G

1

ITEM

NAME

SHEET NAME

PAID

NOT PAID

RECEIVED

NOT REICEVED

2

1

MKK

MK

13,000.00

3

2

MKK

MT

85,400.00

1,000.00

4

3

MKK

ATS

910.00

1,245.00

5

4

MLL

MK

20,000.00

6

5

MLL

MT

1,000.00

7,430.00

7

6

MLL

ATS

950.00

8

7

MSS

MK

11,680.00

9

8

MSS

MS

695.00

10

9

MSS

ATS

640.00

11

10

MTT

MT

1,950.00

12

11

MVS

MK

16,800.00

24,350.00

13

12

MVS

MT

3,800.00

14

13

MVS

MS

995.00

345.00

15

TOTAL

52,300.00

37,275.00

91,195.00

11,420.00

16

NET

38,895.00

FINAL

Try the following macro:

VBA Code:

Sub merging_multiple_columns()
  Dim a As Variant, b As Variant, ky As Variant
  Dim dic As Object
  Dim i&, j&, u&, y&, lr&, nRow
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("SUMMARY")
    lr = .Range("B" & Rows.Count).End(3).Row
    a = .Range("A1:J" & lr).Value
    u = Evaluate(Replace("=SUMPRODUCT((@<>"""")/COUNTIF(@,@&""""))", "@", .Name & "!B3:B" & lr)) 'unique
  End With
  
  ReDim b(1 To (u * 4) + 2, 1 To 7)
  For i = 3 To UBound(a)
    For j = 3 To 10
      If a(i, j) <> 0 Then
        ky = a(i, 2) & "|" & IIf(a(1, j) = "", j - 1 & "@" & a(1, j - 1), j & "@" & a(1, j))
        If Not dic.exists(ky) Then
          y = y + 1
          dic(ky) = y
        End If
        nRow = dic(ky)
        b(nRow, 2) = Split(ky, "|")(0)
        b(nRow, 3) = Split(ky, "|")(1)
        Select Case j
          Case 3, 9
            b(nRow, 4) = b(nRow, 4) + a(i, j)
          Case 4, 10
            b(nRow, 5) = b(nRow, 5) + a(i, j)
          Case 5, 7
            b(nRow, 6) = b(nRow, 6) + a(i, j)
          Case 6, 8
            b(nRow, 7) = b(nRow, 7) + a(i, j)
        End Select
      End If
    Next
  Next
  
  Application.ScreenUpdating = False
  With Sheets("FINAL")
    .Range("A:G").Clear
    .Range("A:G").HorizontalAlignment = xlCenter
    .Range("D:G").NumberFormat = "#,##0.00"
    
    With .Range("A1").Resize(1, 7)
      .Value = Array("ITEM", "NAME", "SHEET NAME", "PAID", "NOT PAID", "RECEIVED", "NOT REICEVED")
      .Borders.LineStyle = xlContinuous
      .Borders.Color = 11184814
      .Interior.ColorIndex = 16
    End With
    
    With .Range("A2").Resize(y, UBound(b, 2))
      .Value = b
      .Borders.LineStyle = xlContinuous
      .Borders.Color = 11184814
      .Sort .Range("B2"), xlAscending, .Range("C2"), , xlAscending, Header:=xlNo
    End With
    
    With .Range("A2")
      .Value = 1
      .Resize(y).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    
    With .Range("C:C")
      .Replace "3@", "", xlPart
      .Replace "5@", "", xlPart
      .Replace "7@", "", xlPart
      .Replace "9@", "", xlPart
    End With
    
    With .Range("A" & y + 2)
      .Value = "TOTAL"
      .Interior.Color = vbYellow
      .Font.Bold = True
      .Offset(0, 3).Value = WorksheetFunction.Sum(.Parent.Range("D2:D" & y + 1))
      .Offset(0, 4).Value = WorksheetFunction.Sum(.Parent.Range("E2:E" & y + 1))
      .Offset(0, 5).Value = WorksheetFunction.Sum(.Parent.Range("F2:F" & y + 1))
      .Offset(0, 6).Value = WorksheetFunction.Sum(.Parent.Range("G2:G" & y + 1))
      With .Resize(2, 7)
        .Borders.LineStyle = xlContinuous
        .Borders.Color = 11184814
      End With
    End With
    
    With .Range("A" & y + 3)
      .Value = "NET"
      .Interior.Color = vbYellow
      .Font.Bold = True
      .Offset(0, 6).Value = .Parent.Range("F" & y + 2) - .Parent.Range("D" & y + 2)
    End With
  End With
  Application.ScreenUpdating = True
End Sub

Maklil · Jan 15, 2025

thanks Dante.

I think some values in your output example are not grouped in the correct row:

I agree with you .
I tested , I have two things :
first I would show zero as hyphen in empty cells.
second about running speed with 15000 row I think the code is slow , gives me 24.50 sec.

DanteAmor · Jan 15, 2025

Maklil said:
first I would show zero as hyphen in empty cells.

ok

Maklil said:
second about running speed with 15000 row I think the code is slow , gives me 24.50 sec.

In your final result you have too many formats in the cells. And it also have to sort the data.

Try the following macro to know how long the macro runs without formats. I also made some improvements.

VBA Code:

Sub merging_multiple_columns()
  Dim a As Variant, b As Variant, ky As Variant
  Dim dic As Object
  Dim i&, j&, u&, y&, lr&, nRow&
  Dim t1 As Double, t2 As Double, t3 As Double, t4 As Double
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("SUMMARY")
    lr = .Range("B" & Rows.Count).End(3).Row
    a = .Range("A1:J" & lr).Value
'    u = Evaluate(Replace("=SUMPRODUCT((@<>"""")/COUNTIF(@,@&""""))", "@", .Name & "!B3:B" & lr)) 'unique
    For i = 3 To UBound(a)
      dic(a(i, 2)) = Empty
    Next
    u = dic.Count
  End With
  
  ReDim b(1 To (u * 4) + 2, 1 To 7)
  For i = 3 To UBound(a)
    For j = 3 To 10
      If a(i, j) <> 0 Then
        ky = a(i, 2) & "|" & IIf(a(1, j) = "", a(1, j - 1), a(1, j))
'        ky = a(i, 2) & "|" & IIf(a(1, j) = "", j - 1 & "@" & a(1, j - 1), j & "@" & a(1, j))
        If Not dic.exists(ky) Then
          y = y + 1
          dic(ky) = y
        End If
        nRow = dic(ky)
        b(nRow, 2) = Split(ky, "|")(0)
        b(nRow, 3) = Split(ky, "|")(1)
        Select Case j
          Case 3, 9
            b(nRow, 4) = b(nRow, 4) + a(i, j)
            t1 = t1 + a(i, j)
          Case 4, 10
            b(nRow, 5) = b(nRow, 5) + a(i, j)
            t2 = t2 + a(i, j)
          Case 5, 7
            b(nRow, 6) = b(nRow, 6) + a(i, j)
            t3 = t3 + a(i, j)
          Case 6, 8
            b(nRow, 7) = b(nRow, 7) + a(i, j)
            t4 = t4 + a(i, j)
        End Select
      End If
    Next
  Next
  
  Application.ScreenUpdating = False
  With Sheets("FINAL")
    .Range("A:G").Clear
    .Range("A:G").HorizontalAlignment = xlCenter
    .Range("D:G").NumberFormat = "#,##0.00;;-"
    
    With .Range("A1").Resize(1, 7)
      .Value = Array("ITEM", "NAME", "SHEET NAME", "PAID", "NOT PAID", "RECEIVED", "NOT REICEVED")
      .Interior.ColorIndex = 16
    End With
    
    With .Range("A2").Resize(y, UBound(b, 2))
      .Value = b
      .Parent.Range("D2:G" & y + 1).SpecialCells(xlCellTypeBlanks).Value = 0
      .Sort .Range("B2"), xlAscending, .Range("C2"), , xlAscending, Header:=xlNo
    End With
    
    With .Range("A2")
      .Value = 1
      .Resize(y).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    
'    With .Range("C:C")
'      .Replace "3@", "", xlPart
'      .Replace "5@", "", xlPart
'      .Replace "7@", "", xlPart
'      .Replace "9@", "", xlPart
'    End With
    
    With .Range("A" & y + 2)
      .Value = "TOTAL"
      .Offset(0, 3).Value = t1
      .Offset(0, 4).Value = t2
      .Offset(0, 5).Value = t3
      .Offset(0, 6).Value = t4
    End With
    
    With .Range("A" & y + 3)
      .Value = "NET"
      .Offset(0, 6).Value = .Parent.Range("F" & y + 2) - .Parent.Range("D" & y + 2)
    End With
    
    lr = .Range("G" & Rows.Count).End(3).Row
'    With .Range("A1:G" & lr)
'      .Borders.LineStyle = xlContinuous
'      .Borders.Color = 11184814
'    End With

    With .Range("A" & lr - 1 & ":A" & lr)
      .Interior.Color = vbYellow
      .Font.Bold = True
    End With
    
  End With
  Application.ScreenUpdating = True
End Sub

Maklil · Thursday at 3:27 AM

Try the following macro to know how long the macro runs without formats. I also made some improvements.

Awesome !
really fast and gives 0.610 sec
also when enable theses

VBA Code:

 With .Range("C:C")
      .Replace "3@", "", xlPart
      .Replace "5@", "", xlPart
      .Replace "7@", "", xlPart
      .Replace "9@", "", xlPart
    End With
    
    
  
    With .Range("A1:G" & lr)
      .Borders.LineStyle = xlContinuous
      .Borders.Color = 11184814
    End With

the same speed , there is no difference.
indeed I don't understand theses

With .Range("C:C")
.Replace "3@", "", xlPart
.Replace "5@", "", xlPart
.Replace "7@", "", xlPart
.Replace "9@", "", xlPart
End With

what work for it?

anyway thank you so much for your time and help.

DanteAmor · Thursday at 9:22 AM

Maklil said:
the same speed , there is no difference.
indeed I don't understand theses

It is to sort columns B and C with respect to the order in which they appear in the columns:

Maklil said:
also when enable theses

Then try this:

VBA Code:

Sub merging_multiple_columns()
  Dim a As Variant, b As Variant, ky As Variant
  Dim dic As Object
  Dim i&, j&, u&, y&, lr&, nRow&
  Dim t1 As Double, t2 As Double, t3 As Double, t4 As Double
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Sheets("SUMMARY")
    lr = .Range("B" & Rows.Count).End(3).Row
    a = .Range("A1:J" & lr).Value

    For i = 3 To UBound(a)
      dic(a(i, 2)) = Empty
    Next
    u = dic.Count
  End With
  
  ReDim b(1 To (u * 4) + 2, 1 To 7)
  For i = 3 To UBound(a)
    For j = 3 To 10
      If a(i, j) <> 0 Then
'        ky = a(i, 2) & "|" & IIf(a(1, j) = "", a(1, j - 1), a(1, j))
        ky = a(i, 2) & "|" & IIf(a(1, j) = "", j - 1 & "@" & a(1, j - 1), j & "@" & a(1, j))
        If Not dic.exists(ky) Then
          y = y + 1
          dic(ky) = y
        End If
        nRow = dic(ky)
        b(nRow, 2) = Split(ky, "|")(0)
        b(nRow, 3) = Split(ky, "|")(1)
        Select Case j
          Case 3, 9
            b(nRow, 4) = b(nRow, 4) + a(i, j)
            t1 = t1 + a(i, j)
          Case 4, 10
            b(nRow, 5) = b(nRow, 5) + a(i, j)
            t2 = t2 + a(i, j)
          Case 5, 7
            b(nRow, 6) = b(nRow, 6) + a(i, j)
            t3 = t3 + a(i, j)
          Case 6, 8
            b(nRow, 7) = b(nRow, 7) + a(i, j)
            t4 = t4 + a(i, j)
        End Select
      End If
    Next
  Next
  
  Application.ScreenUpdating = False
  With Sheets("FINAL")
    .Range("A:G").Clear
    .Range("A:G").HorizontalAlignment = xlCenter
    .Range("D:G").NumberFormat = "#,##0.00;;-"
    
    With .Range("A1").Resize(1, 7)
      .Value = Array("ITEM", "NAME", "SHEET NAME", "PAID", "NOT PAID", "RECEIVED", "NOT REICEVED")
      .Interior.ColorIndex = 16
    End With
    
    With .Range("A2").Resize(y, UBound(b, 2))
      .Value = b
      .Parent.Range("D2:G" & y + 1).SpecialCells(xlCellTypeBlanks).Value = 0
      .Sort .Range("B2"), xlAscending, .Range("C2"), , xlAscending, Header:=xlNo
    End With
    
    With .Range("A2")
      .Value = 1
      .Resize(y).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    
    With .Range("C:C")
      .Replace "3@", "", xlPart
      .Replace "5@", "", xlPart
      .Replace "7@", "", xlPart
      .Replace "9@", "", xlPart
    End With
    
    With .Range("A" & y + 2)
      .Value = "TOTAL"
      .Offset(0, 3).Value = t1
      .Offset(0, 4).Value = t2
      .Offset(0, 5).Value = t3
      .Offset(0, 6).Value = t4
    End With
    
    With .Range("A" & y + 3)
      .Value = "NET"
      .Offset(0, 6).Value = .Parent.Range("F" & y + 2) - .Parent.Range("D" & y + 2)
    End With
    
    lr = .Range("G" & Rows.Count).End(3).Row
    With .Range("A1:G" & lr)
      .Borders.LineStyle = xlContinuous
      .Borders.Color = 11184814
    End With

    With .Range("A" & lr - 1 & ":A" & lr)
      .Interior.Color = vbYellow
      .Font.Bold = True
    End With
    
  End With
  Application.ScreenUpdating = True
End Sub

Maklil said:
second about running speed with 15000 row I think the code is slow , gives me 24.50 sec.

Consider that there are 15,000 records but 8 columns have to be reviewed, 120 thousand cells are actually read.

Maklil · Sunday at 4:13 AM

it keep the code in post#4 is the best despite of this is not big difference.

the last version will give 0.9 and in post#4 gives 0.6 .
thanks again.

Macro to merging for multiple columns contain same headers

Maklil

Board Regular

Excel Facts

DanteAmor

Well-known Member

Maklil

Board Regular

DanteAmor

Well-known Member

Maklil

Board Regular

DanteAmor

Well-known Member

Maklil

Board Regular

Similar threads

Forum statistics

Share this page

Macro to merging for multiple columns contain same headers

Maklil

Board Regular

Excel Facts

DanteAmor

Well-known Member

Maklil

Board Regular

DanteAmor

Well-known Member

Maklil

Board Regular

DanteAmor

Well-known Member

Maklil

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock