excel vba that moves over merged cells

[BORUCH]

hi all

i have a data set that looks like below

Book1
	A	B	C	D	E	F	G	H	I	J
1	Item #	Description	qty	price	qty	price	qty	price	qty	price
2	00000	test 1	10	$12.00	20	$11.00	30	$10.00
3	00001	test 2
4	00002	test 3
5
6	00004	test 5	9	$13.00	25	$9.00
7	00005	test 6
8	00006	test 7
9
10	00008	test 9	10	$14.00	20	$15.66	30	$14.00	40	$13.00
Sheet1

i would like an excel vba that does this below

Book1
	M	N	O	P	Q	R	S	T	U	V	W	X
1	Item #	Description	qty	price	qty	price	qty	price	qty	price
2	00000	test 1	10	$12.00	20	$11.00			30	$10.00
3	00001	test 2
4	00002	test 3
5
6	00004	test 5	10	$13.00			25	$9.00
7	00005	test 6
8	00006	test 7
9
10	00008	test 9	10	$14.00	20	$15.66	30	$14.00			40	$13.00
Sheet1

as you can see it moved over every group to the right

any suggestions is greatly appreciated

 

[Ezguy4u]

Boruch so I am going to assume a group is qty and price. So it that is true Item# 00001 test2 20 $11.00 doesn't look like it has been moved over to the right. Was this by design or did you miss that?

 

[BORUCH]

Boruch so I am going to assume a group is qty and price. So it that is true Item# 00001 test2 20 $11.00 doesn't look like it has been moved over to the right. Was this by design or did you miss that?

hi

yes, its by design i want to to only move over the last group.

 

[BORUCH]

Boruch so I am going to assume a group is qty and price. So it that is true Item# 00001 test2 20 $11.00 doesn't look like it has been moved over to the right. Was this by design or did you miss that?

hi

any suggestions ?

 

[jolivanes]

This assumes you have nothing to the right of the data shown in your example

Sub Try_So()
Dim myAreas As Areas
Dim sh1 As Worksheet
Dim lr As Long, i As Long, lc As Long, fcel As Long, lcel As Long
Set sh1 = ThisWorkbook.Sheets("Sheet1")    '<---- Change as required
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set myAreas = sh1.Range("A2:A" & lr).SpecialCells(2).Areas
    For i = 1 To myAreas.Count
        fcel = myAreas(i).Cells(1).Row
        lcel = fcel + myAreas(i).Rows.Count - 1
        lc = Rows(fcel & ":" & lcel).Find("*", , , , 2, 2).Column
        myAreas(i).Offset(, lc - 2).Resize(, 2).Insert Shift:=xlToRight
    Next i
End Sub

Please don't quote this post if you reply. Just extra clutter we don't need.

 

[BORUCH]

Set myAreas = sh1.Range("C2:C" & lr).SpecialCells(2).Areas

getting error no cells were found

 

[jolivanes]

That is not from what I suggested. The code in Post #5 suggests the first Column (Set myAreas = sh1.Range("A2:A" & lr).SpecialCells(2).Areas)
So you changed it but no explanation why it should be changed. Is the example not representative of your actual data?
The code will work only if Cells A5 and A9, as in your example, are actual empty cells.
So if you changed things, we need to know what is changed.

 

[Ezguy4u]

Boruch we want to make these programs dynamic so set up is important. We have to be consistent in how the data is presented. The below program works if the data looks like the worksheet below. Now there may be a few more things we have to tweek but let's see if this works for you.

Sub Prog09()
Dim row1 As Long
Dim ColCnt As Long

row1 = Cells(Rows.Count, "A").End(xlUp).Row - 2
ColCnt = Cells(2, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False

For i = 2 To row1 Step 4

Range((Cells(i, ColCnt - 1)), Cells(i, ColCnt)).Select

     Selection.Cut Destination:=Range((Cells(i, ColCnt + 1)), Cells(i, ColCnt + 2))

ColCnt = Cells(i + 4, Columns.Count).End(xlToLeft).Column

Next i
Application.ScreenUpdating = True
End Sub

23-12-26 rev b.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Item #	Description	qty	price	qty	price	qty	price	qty	price	qty
2	00000	test 1	10	$ 12.00	20	$ 11.00	30	$ 10.00
3	00001	test 2
4	00002	test 3
5
6	00004	test 5	9	$ 13.00	25	$ 9.00
7	00005	test 6
8	00006	test 7
9
10	00000	test 1	10	$ 12.00	20	$ 11.00	30	$ 10.00	15	$ 12.00
11	00001	test 2
12	00002	test 3
Data

 

[BORUCH]

Boruch we want to make these programs dynamic so set up is important. We have to be consistent in how the data is presented. The below program works if the data looks like the worksheet below. Now there may be a few more things we have to tweek but let's see if this works for you.

Sub Prog09()
Dim row1 As Long
Dim ColCnt As Long

row1 = Cells(Rows.Count, "A").End(xlUp).Row - 2
ColCnt = Cells(2, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False

For i = 2 To row1 Step 4

Range((Cells(i, ColCnt - 1)), Cells(i, ColCnt)).Select

     Selection.Cut Destination:=Range((Cells(i, ColCnt + 1)), Cells(i, ColCnt + 2))

ColCnt = Cells(i + 4, Columns.Count).End(xlToLeft).Column

Next i
Application.ScreenUpdating = True
End Sub

23-12-26 rev b.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Item #	Description	qty	price	qty	price	qty	price	qty	price	qty
2	00000	test 1	10	$ 12.00	20	$ 11.00	30	$ 10.00
3	00001	test 2
4	00002	test 3
5
6	00004	test 5	9	$ 13.00	25	$ 9.00
7	00005	test 6
8	00006	test 7
9
10	00000	test 1	10	$ 12.00	20	$ 11.00	30	$ 10.00	15	$ 12.00
11	00001	test 2
12	00002	test 3
Data

hi i was just uploading test data my actual date looks like this

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3
4
5
6
7
8
9
10
11
12	Item #	Description	Other 1	Other 2	Other 3	Qty	Price	Qty	Price	Qty	Price	Qty	Price
13	00000	test 1				10	$ 12.00	20	$11.00	30	$10.00
14	00001	test 2
15	00002	test 3
16
17	00004	test 5				9	$ 13.00	25	$ 9.00
18	00005	test 6
19	00006	test 7
20
21	00008	test 9				10	$ 14.00	20	$15.66	30	$14.00
22
23	00011	test 10				5	$100.00	10	$90.00
24	00012	test 11
25	00013	test 12
26	00014	test 13
27	00015	test 14
28	00016	test 15
Sheet1

and what i want is

Book1
	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA
1
2
3
4
5
6
7
8
9
10
11
12	Item #	Description	Other 1	Other 2	Other 3	Qty	Price	Qty	Price	Qty	Price	Qty	Price
13	00000	test 1				10	$ 12.00	20	$11.00			30	$10.00
14	00001	test 2
15	00002	test 3
16
17	00004	test 5				9	$ 13.00			25	$ 9.00
18	00005	test 6
19	00006	test 7
20
21	00008	test 9				10	$ 14.00	20	$15.66			30	$14.00
22
23	00011	test 10				5	$100.00			10	$90.00
24	00012	test 11
25	00013	test 12
26	00014	test 13
27	00015	test 14
28	00016	test 15
Sheet1

if you can change your code to accommodate this

thanks

 

[jolivanes]

All you have to do is change A2 to A13 in the myAreas line from Post #5.

I am done because your last post is just a copy, quote, from the previous post for no reason what-so-ever in my mind. Like I mentioned previously. One way to clutter the world.