rearranging data based on headers and get rid of merged cells

abdo meghari · Jul 10, 2024

Hi
I search for macro to arrange data across sheets based on headers(TOTAL,DATE,INVOICE NO,UNIT PRICE,QTY,CODE,BRAND), (MOVEMENT : PURCHASING,MOVEMENT : SELLING) and get rid of merged cells
alaways data start from row 8 for first sheet and others sheets start from row4
original data in all of sheets

KashfMabiatReport1.xls

A

B

C

D

E

F

G

H

I

J

K

L

8

MOVEMENT : PURCHASING

9

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

10

242,560.000

2024.01.02

114

895.000

80

1284

GC 1200R20 AZ0026 CHI

11

925.000

40

1285

GC 1200R20 AZ0183 CHI

12

735.000

20

1385

GC 315/80R22.5 AT161 CHI

13

735.000

20

1287

GC 315/80R22.5 AZ126 CHI

14

745.000

20

1294

GC 315/80R22.5 AZ188 CHI

15

2,035.000

40

1241

BS 1200R20 G580 JAP

16

425.000

8

1227

BS 215/70R15C R623 THI

17

405.000

12

1221

BS 205/70R15C R623 THI

18

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

19

114,840.000

2024.01.09

121

715.000

80

1306

BS 750R16 R230 JAP

20

515.000

40

1310

BS 225/95R16C D618 JAP

21

535.000

50

1391

BS 265/65R17 D840 JAP

22

735.000

14

1287

GC 315/80R22.5 AZ126 CHI

23

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

24

850.000

2024.01.10

125

425.000

2

1227

BS 215/70R15C R623 THI

25

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

26

5,210.000

2024.01.17

138

570.000

5

1401

BS 650R16 R230 JAP

27

590.000

4

1402

BS 245/70R16 D697 JAP

28

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

29

41,550.000

2024.01.20

148

935.000

24

1292

GC 1200R24 AZ166 CHI

30

735.000

26

1287

GC 315/80R22.5 AZ126 CHI

31

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

32

411,770.000

2024.01.20

149

405.000

50

1221

BS 205/70R15C R623 THI

33

425.000

12

1227

BS 215/70R15C R623 THI

34

505.000

24

1346

BS 255/70R15C D840

35

2,035.000

180

1241

BS 1200R20 G580 JAP

36

2,000.000

4

1244

BS 1200R20 R187 JAP

37

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

38

11,205.000

2024.01.21

280

705.000

1

1190

BS 285/50R20 DSPORT JAP

39

725.000

4

1411

BS 275/55R20 ALENZA1 JAP

40

1,900.000

4

1269

BS 1200R24 G580 JAP

41

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

42

9,400.000

2024.03.26

215

940.000

10

1306

BS 750R16 R230 JAP

Page 0

KashfMabiatReport1.xls

A

B

C

D

E

F

G

H

I

J

4

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

5

16,557.000

2024.06.26

336

690.000

5

1391

BS 265/65R17 D840 JAP

6

942.000

4

1411

BS 275/55R20 ALENZA1 JAP

7

544.000

16

1227

BS 215/70R15C R623 THI

8

635.000

1

1346

BS 255/70R15C D840

9

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

10

24,884.000

2024.07.03

347

635.000

8

1346

BS 255/70R15C D840

11

625.000

4

1547

BS 205R16C D840 THI

12

721.000

24

1326

BS 265/60R18 D840 JAP

13

14

MOVEMENT : SELLING

15

TOTAL

DATE

INVOICE NO

UNIT PRICE

QTY

CODE

BRAND

16

7,750.000

2024.01.24

561

775.000

10

1306

BS 750R16 R230 JAP

17

18

SUMMARY

19

1,891,459.000

TOTAL PURCHASE

20

7,750.000

TOTAL SELLING

21

2,120,485.000

TOTAL PAID

Page 3

result in INVOICES sheet

KashfMabiatReport1.xls

A

B

C

D

E

F

G

3

MOVEMENT : PURCHASING

4

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

5

2024.01.02

114

1284

GC 1200R20 AZ0026 CHI

80

895.000

242,560.000

6

1285

GC 1200R20 AZ0183 CHI

40

925.000

7

1385

GC 315/80R22.5 AT161 CHI

20

735.000

8

1287

GC 315/80R22.5 AZ126 CHI

20

735.000

9

1294

GC 315/80R22.5 AZ188 CHI

20

745.000

10

1241

BS 1200R20 G580 JAP

40

2,035.000

11

1227

BS 215/70R15C R623 THI

8

425.000

12

1221

BS 205/70R15C R623 THI

12

405.000

13

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

14

2024.01.09

121

1306

BS 750R16 R230 JAP

80

715.000

114,840.000

15

1310

BS 225/95R16C D618 JAP

40

515.000

16

1391

BS 265/65R17 D840 JAP

50

535.000

17

1287

GC 315/80R22.5 AZ126 CHI

14

735.000

18

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

19

2024.01.10

125

1227

BS 215/70R15C R623 THI

2

425.000

850.000

20

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

21

2024.01.17

138

1401

BS 650R16 R230 JAP

5

570.000

5,210.000

22

1402

BS 245/70R16 D697 JAP

4

590.000

23

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

24

2024.01.20

148

1292

GC 1200R24 AZ166 CHI

24

935.000

41,550.000

25

1287

GC 315/80R22.5 AZ126 CHI

26

735.000

26

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

27

2024.01.20

149

1221

BS 205/70R15C R623 THI

50

405.000

411,770.000

28

1227

BS 215/70R15C R623 THI

12

425.000

29

1346

BS 255/70R15C D840

24

505.000

30

1241

BS 1200R20 G580 JAP

180

2,035.000

31

1244

BS 1200R20 R187 JAP

4

2,000.000

32

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

33

2024.01.21

280

1190

BS 285/50R20 DSPORT JAP

1

705.000

11,205.000

34

1411

BS 275/55R20 ALENZA1 JAP

4

725.000

35

1269

BS 1200R24 G580 JAP

4

1,900.000

36

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

37

2024.03.26

215

1306

BS 750R16 R230 JAP

10

940.000

9,400.000

38

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

39

2024.06.26

336

1391

BS 265/65R17 D840 JAP

5

690.000

16,557.000

40

1411

BS 275/55R20 ALENZA1 JAP

4

942.000

41

1227

BS 215/70R15C R623 THI

16

544.000

42

1346

BS 255/70R15C D840

1

635.000

43

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

44

2024.07.03

347

1346

BS 255/70R15C D840

8

635.000

24,884.000

45

1547

BS 205R16C D840 THI

4

625.000

46

1326

BS 265/60R18 D840 JAP

24

721.000

47

MOVEMENT : SELLING

48

DATE

INVOICE NO

CODE

BRAND

QTY

UNIT PRICE

TOTAL

49

2024.01.24

561

1306

BS 750R16 R230 JAP

10

775.000

7,750.000

50

51

52

SUMMARY

53

TOTAL PURCHASE

1,891,459.000

54

TOTAL SELLING

7,750.000

55

TOTAL PAID

2,120,485.000

56

INVOICES

I can't post the others sheets because XL2BB tool prohibit for much character
thanks

abdo meghari · Jul 18, 2024

Does the file contains INVOICES sheet or is to be created by macro.

I wish to to be created by macro without repeat adding INVOICES sheet when run the macro every time .
the code works greatly

kvsrinivasamurthy · Jul 19, 2024

Modified code is here. If INVOICES sheet is not there it will be added, else INVOICES sheet data will be erased and new data will be uploaded.

VBA Code:

Sub Rearrange_Data1()
Dim cnt&, clm&, T&, S$, K&, X&, m&
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim Sh As Worksheet
Dim Lastsh$
On Error Resume Next
Sheets("INVOICES").Cells.Clear
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "INVOICES"
On Error GoTo 0

For Each Sh In Worksheets
If Sh.Name = "Page 0" Then
K = 8
ElseIf Left(Sh.Name, 4) = "Page" Then
K = 4
Else
K = 0
End If

If K <> 0 Then
With Sh.Range("A" & K)
clm = 0
    cnt = Sh.Cells(K + 1, Columns.Count).End(xlToLeft).Column
    With .CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng = .Columns(clm).Find("*")
    If Rng Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 1)
 End With
Lastsh = Sh.Name
End If
Next Sh

With Sheets(Lastsh)
Set Rng1 = .Cells.Find("SELLING")
If Not Rng1 Is Nothing Then
    clm = 0
    m = Rng1.Row + 2
    cnt = .Cells(m, Columns.Count).End(xlToLeft).Column
   
    With .Cells(Rng1.Row, 1).CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng2 = .Columns(clm).Find("*")
    If Rng2 Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .Cells(Rng1.Row, 1).CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 1)
   ' End With

End If
End With

With Sheets("INVOICES").Range("A1").CurrentRegion
.Columns(5).Copy .Cells(1, .Columns.Count + 1)
.Columns(4).Copy .Cells(1, .Columns.Count + 2)
.Columns(1).Copy .Cells(1, .Columns.Count + 3)
.Columns(5).Delete Shift:=xlToLeft
.Columns(4).Delete Shift:=xlToLeft
.Columns(1).Delete Shift:=xlToLeft
.Cells(2, 7).Cut .Cells(2, 4)
.Cells(X + 1, 7).Cut .Cells(X + 1, 4)
.WrapText = False
End With

With Sheets(Lastsh)
Set Rng3 = .Cells.Find("SUMMARY")
If Not Rng3 Is Nothing Then
    clm = 0
    m = Rng3.Row + 2
    cnt = .Cells(m, Columns.Count).End(xlToLeft).Column
    With .Cells(Rng3.Row, 1).CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng4 = .Columns(clm).Find("*")
    If Rng4 Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .Cells(Rng3.Row, 1).CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 3)

End If
End With

With Sheets("INVOICES").Range("A" & X + 3).CurrentRegion
.Cells(1, 1).Copy .Cells(1, 2)
.Columns(1).Offset(1, 0).Copy .Cells(2, .Columns.Count + 1)
.Columns(1).Delete Shift:=xlToLeft
.WrapText = False
End With

Sheets("INVOICES").UsedRange.EntireColumn.AutoFit  '.Columns("A:K")

End Sub

abdo meghari · Jul 19, 2024

Thank you , but why add empty new sheet when every time run the macro?!
may you fix it ,please?

kvsrinivasamurthy · Jul 20, 2024

Code modified .

VBA Code:

Sub Rearrange_Data1()
Dim cnt&, clm&, T&, S$, K&, X&, m&
Dim Rng As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim Sh As Worksheet
Dim Lastsh$
On Error Resume Next
Sheets("INVOICES").Cells.Clear
If Err.Number <> 0 Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "INVOICES"
On Error GoTo 0

For Each Sh In Worksheets
If Sh.Name = "Page 0" Then
K = 8
ElseIf Left(Sh.Name, 4) = "Page" Then
K = 4
Else
K = 0
End If

If K <> 0 Then
With Sh.Range("A" & K)
clm = 0
    cnt = Sh.Cells(K + 1, Columns.Count).End(xlToLeft).Column
    With .CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng = .Columns(clm).Find("*")
    If Rng Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 1)
 End With
Lastsh = Sh.Name
End If
Next Sh

With Sheets(Lastsh)
Set Rng1 = .Cells.Find("SELLING")
If Not Rng1 Is Nothing Then
    clm = 0
    m = Rng1.Row + 2
    cnt = .Cells(m, Columns.Count).End(xlToLeft).Column
    
    With .Cells(Rng1.Row, 1).CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng2 = .Columns(clm).Find("*")
    If Rng2 Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .Cells(Rng1.Row, 1).CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 1)
   ' End With

End If
End With

With Sheets("INVOICES").Range("A1").CurrentRegion
.Columns(5).Copy .Cells(1, .Columns.Count + 1)
.Columns(4).Copy .Cells(1, .Columns.Count + 2)
.Columns(1).Copy .Cells(1, .Columns.Count + 3)
.Columns(5).Delete Shift:=xlToLeft
.Columns(4).Delete Shift:=xlToLeft
.Columns(1).Delete Shift:=xlToLeft
.Cells(2, 7).Cut .Cells(2, 4)
.Cells(X + 1, 7).Cut .Cells(X + 1, 4)
.WrapText = False
End With

With Sheets(Lastsh)
Set Rng3 = .Cells.Find("SUMMARY")
If Not Rng3 Is Nothing Then
    clm = 0
    m = Rng3.Row + 2
    cnt = .Cells(m, Columns.Count).End(xlToLeft).Column
    With .Cells(Rng3.Row, 1).CurrentRegion
    .UnMerge
    For T = 1 To cnt
    clm = clm + 1
    Set Rng4 = .Columns(clm).Find("*")
    If Rng4 Is Nothing Then
    .Columns(clm).Delete Shift:=xlToLeft
    clm = clm - 1
    End If
    Next T
    End With
    X = Sheets("INVOICES").Range("D" & Rows.Count).End(xlUp).Row
    .Cells(Rng3.Row, 1).CurrentRegion.Copy Sheets("INVOICES").Range("A" & X + 3)

End If
End With

With Sheets("INVOICES").Range("A" & X + 3).CurrentRegion
.Cells(1, 1).Copy .Cells(1, 2)
.Columns(1).Offset(1, 0).Copy .Cells(2, .Columns.Count + 1)
.Columns(1).Delete Shift:=xlToLeft
.WrapText = False
End With

Sheets("INVOICES").UsedRange.EntireColumn.AutoFit  '.Columns("A:K")

End Sub

abdo meghari · Jul 20, 2024

Thank you so much

kvsrinivasamurthy · Jul 20, 2024

Welcome.

rearranging data based on headers and get rid of merged cells

abdo meghari

Well-known Member

abdo meghari

Well-known Member

Excel Facts

kvsrinivasamurthy

Well-known Member

abdo meghari

Well-known Member

kvsrinivasamurthy

Well-known Member

abdo meghari

Well-known Member

kvsrinivasamurthy

Well-known Member

Similar threads

Forum statistics

Share this page

rearranging data based on headers and get rid of merged cells

abdo meghari

Well-known Member

abdo meghari

Well-known Member

Excel Facts

kvsrinivasamurthy

Well-known Member

abdo meghari

Well-known Member

kvsrinivasamurthy

Well-known Member

abdo meghari

Well-known Member

kvsrinivasamurthy

Well-known Member

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