rearranging data based on headers and get rid of merged cells

[abdo meghari]

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

 

[kvsrinivasamurthy]

Try this macro. Works on active sheet.

Sub Rearrange_Data()
Dim cnt&, T&, S$
Dim K As Range
    With ActiveSheet.UsedRange
    cnt = .Columns.Count
    .UnMerge
    For T = 1 To cnt
    Set K = .Columns(T).Find("*")
    If K Is Nothing Then S = S & "," & .Cells(1, T).Address
    Next T
    End With
   
    If S <> "" Then Range(Mid(S, 2)).EntireColumn.Delete
   
End Sub

 

[abdo meghari]

thanks
your code just delete merged cells without change arranging columns again as I put in result !

 

[kvsrinivasamurthy]

File is required to give required result. Upload file in some website and give link here to download.

 

[abdo meghari]

OK
I will do it tomorrow because work is off today.

 

[abdo meghari]

I hope you have time to see my attachment.

Dropbox

 

[abdo meghari]

hey did you see my last post?

 

[abdo meghari]

posted in this forum
rearranging data based on headers and get rid of merged cells

 

[kvsrinivasamurthy]

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

 

[kvsrinivasamurthy]

Try this code. I have verified with your file. Working OK.

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$

Sheets("INVOICES").Cells.Clear
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