VBA elusive copy multiple rows as per given data in column G

[Kishan]

Using Excel 2000

Hi,

VBA that copy as per number of row mention in cells G6:G15 from a columns C, D, E and paste in to as explain continuation....
If rows to be copied start with 1 than to be past in column I, J, & K
If rows to be copied start with X than to be past in column M, N, & O
If rows to be copied start with 2 than to be past in column Q, R, & S

For example:
G6=3 copy 3 rows C6:E8 as start of the copy row C6=X this paste in to M6:O8
G7=6 copy 6 rows C9:E14 as start of the copy row C9=X this paste in to M9:O14
G8=6 copy 6 rows C15:E20 as start of the copy row C15=1 this paste in to I6:K11
G9=5 copy 5 rows C21:E25 as start of the copy row C21=2 this paste in to Q6:S10
And so on...

Example data

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1
2
3
4
5			C1	C2	C3		Data			1				X				2
6			X	S	X		3		1	S	1		X	S	X		2	S	X
7			2				6		X				2				1
8			1	3	1		6		1				1	3	1		1
9			X	S	X		5		X				X	S	X		1
10			1				12		1				1				X	5	2
11			X				3		2	6	2		X				2	S	2
12			1				6		1	S	1		1				1
13			1				11		1				1				1
14			2	6	2		6		1				2	6	2		1
15			1	S	1		17		1				X	S	X		1
16			X						1				1				X	6	X
17			1						1				2	3	2		2	S	2
18			X						1								1
19			1						1								2
20			2	6	2				2								1
21			2	S	X				2								1
22			1						1								X	6	X
23			1						X	12	X
24			1						1	S	1
25			X	5	2				2
26			1	S	1				1
27			1						1
28			1						2
29			1						1
30			1						1
31			1						1
32			1						1
33			1						1
34			2						X	11	X
35			2						1	S	1
36			1						2
37			X	12	X				2
38			X	S	X				2
39			1						2
40			2	3	2				2
41			2	S	2				1
42			1						1
43			1						2
44			1						2
45			1						1
46			X	6	X				1
47			1	S	1				2
48			2						2
49			1						1
50			1						1
51			2						X	17	X
52			1
53			1
54			1
55			1
56			1
57			X	11	X
58			2	S	2
59			1
60			2
61			1
62			1
63			X	6	X
64			1	S	1
65			2
66			2
67			2
68			2
69			2
70			1
71			1
72			2
73			2
74			1
75			1
76			2
77			2
78			1
79			1
80			X	17	X
81			1	S	1
82			X
83
84
85
86
87
Sheet2

Thank you in advance

Regards
Kishan

 

[JackDanIce]

I do not clearly understand I'm afraid, however, you can change the sheet name in blue so that the macro works across any sheet:

Sub CopyMove()

    Dim arr()   As Variant
    Dim temp()  As Variant
    Dim x       As Long
    Dim r       As Long
    Dim c       As Long
    
    r = 6
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        x = .Cells(.Rows.count, 7).End(xlUp).row - 5
        arr = .Cells(6, 7).Resize(x).Value
            
        For x = LBound(arr, 1) To UBound(arr, 1)
            temp = .Cells(r, 3).Resize(arr(x, 1), 3).Value
            c = 10
            Select Case UCase(.Cells(r, 3).Value)
                Case Is = "X": c = 14
                Case Is = 2: c = 18
            End Select
            .Cells(.Rows.count, c).End(xlUp).Offset(1, -1).Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
            Erase temp
            r = r + arr(x, 1)
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    
End Sub

 

[Kishan]

I do not clearly understand I'm afraid, however, you can change the sheet name in blue so that the macro works across any sheet:

Hi JackDanIce,

Here is an example my data are in the "Sheet Data"

Book1
	A	B	C	D	E	F	G	H
1
2
3
4
5			C1	C2	C3		Data
6			X	S	X		3
7			2				6
8			1	3	1		6
9			X	S	X		5
10			1				12
11			X				3
12			1				6
13			1				11
14			2	6	2		6
15			1	S	1		17
16			X
17			1
18			X
19			1
20			2	6	2
21			2	S	X
22			1
23			1
24			1
25			X	5	2
26			1	S	1
27			1
28			1
29			1
30			1
31			1
32			1
33			1
34			2
35			2
36			1
37			X	12	X
38			X	S	X
39			1
40			2	3	2
41			2	S	2
42			1
43			1
44			1
45			1
46			X	6	X
47			1	S	1
48			2
49			1
50			1
51			2
52			1
53			1
54			1
55			1
56			1
57			X	11	X
58			2	S	2
59			1
60			2
61			1
62			1
63			X	6	X
64			1	S	1
65			2
66			2
67			2
68			2
69			2
70			1
71			1
72			2
73			2
74			1
75			1
76			2
77			2
78			1
79			1
80			X	17	X
81			1	S	1
82			X
83
84
Sheet Data

I want the result in sheet1

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1
2
3
4
5				1				X				2
6			1	S	1		X	S	X		2	S	X
7			X				2				1
8			1				1	3	1		1
9			X				X	S	X		1
10			1				1				X	5	2
11			2	6	2		X				2	S	2
12			1	S	1		1				1
13			1				1				1
14			1				2	6	2		1
15			1				X	S	X		1
16			1				1				X	6	X
17			1				2	3	2		2	S	2
18			1								1
19			1								2
20			2								1
21			2								1
22			1								X	6	X
23			X	12	X
24			1	S	1
25			2
26			1
27			1
28			2
29			1
30			1
31			1
32			1
33			1
34			X	11	X
35			1	S	1
36			2
37			2
38			2
39			2
40			2
41			1
42			1
43			2
44			2
45			1
46			1
47			2
48			2
49			1
50			1
51			X	17	X
52
53
54
Sheet1

Macro post#11 stop at the following line because it was not explained clearly from my side

arr = .Cells(6, 7).Resize(x).Value

Please could you take a look?

Thank you

Kind Regards,
Kishan

 

[JackDanIce]

Try:

Sub CopyMove()


    Dim arr()   As Variant
    
    Dim x       As Long
    Dim r       As Long
    Dim c       As Long
    
    Dim wksData As Worksheet
    Dim wks  As Worksheet
    
    Set wksData = Sheets("Sheet Data")
    Set wks = Sheets("Sheet1")
    r = 6
    
    Application.ScreenUpdating = False
    
    With wksData
        x = .Cells(.Rows.count, 7).End(xlUp).row - 5
        arr = .Cells(6, 7).Resize(x).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            c = 4
            Select Case UCase(.Cells(r, 3).Value)
                Case Is = "X": c = c + 4
                Case Is = 2: c = c + 8
            End Select
            OutputSheet wks, .Cells(r, 3).Resize(arr(x, 1), 3), c
            r = r + arr(x, 1)
        Next x
        
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wksData = Nothing
    Set wksSh1 = Nothing
    
End Sub
Private Sub OutputSheet(ByRef wks As Worksheet, ByRef rng As Range, ByRef col As Long)


    With wks
        .Cells(.Rows.count, col).End(xlUp).Offset(1, -1).Resize(rng.Rows.count, rng.Columns.count).Value = rng.Value
    End With
    
End Sub

 

[Kishan]

Try:

Hi JackDanIce, 
 
It is almost perfect may need little touch copy data as shown below and stop at the line below

	
	
	
	
	
	



	
	

		
 wksSh1.Cells(Rows.Count, c).End(xlUp).Offset(1, -1).Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
	
 

Book1
A
B
C
D
E
F
G
H
I
J
K
L
M
N
1
2
3
4
5
1
X
2
6
1
S
1
X
S
X
7
X
2
8
1
1
3
1
9
X
X
S
X
10
1
1
11
2
6
2
X
12
1
13
1
14
2
6
2
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sheet1


 Please could you take a look?
 
Thank you
 
Kind Regards,
Kishan

 

[JackDanIce]

Testing the code, it does fill in all the values, I do not get the same output as above. Try:

Sub CopyMove()


    Dim arr()   As Variant
    
    Dim x       As Long
    Dim r       As Long
    Dim c       As Long
    
    Dim wksData As Worksheet
    Dim wks  As Worksheet
    
    Set wksData = Sheets("Sheet Data")
    Set wks = Sheets("Sheet1")
    r = 6
    
    Application.ScreenUpdating = False
    
    With wksData
        x = .Cells(.Rows.count, 7).End(xlUp).row - 5
        arr = .Cells(6, 7).Resize(x).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            c = 4
            Select Case UCase(.Cells(r, 3).Value)
                Case Is = "X": c = c + 4
                Case Is = 2: c = c + 8
            End Select
            OutputSheet wks, .Cells(r, 3).Resize(arr(x, 1), 3), c
            r = r + arr(x, 1)
        Next x
        
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wksData = Nothing
    Set wks = Nothing
    
End Sub
Private Sub OutputSheet(ByRef wks As Worksheet, ByRef rng As Range, ByRef col As Long)
    
    With wks
        .Cells(.Rows.count, col).End(xlUp).Offset(1, -1).Resize(rng.Rows.count, rng.Columns.count).Value = rng.Value
    End With


End Sub

 

[Kishan]

Testing the code, it does fill in all the values, I do not get the same output as above. Try:

Sub CopyMove()


    Dim arr()   As Variant
    
    Dim x       As Long
    Dim r       As Long
    Dim c       As Long
    
    Dim wksData As Worksheet
    Dim wks  As Worksheet
    
    Set wksData = Sheets("Sheet Data")
    Set wks = Sheets("Sheet1")
    r = 6
    
    Application.ScreenUpdating = False
    
    With wksData
        x = .Cells(.Rows.count, 7).End(xlUp).row - 5
        arr = .Cells(6, 7).Resize(x).Value
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            c = 4
            Select Case UCase(.Cells(r, 3).Value)
                Case Is = "X": c = c + 4
                Case Is = 2: c = c + 8
            End Select
            OutputSheet wks, .Cells(r, 3).Resize(arr(x, 1), 3), c
            r = r + arr(x, 1)
        Next x
        
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set wksData = Nothing
    Set wks = Nothing
    
End Sub
Private Sub OutputSheet(ByRef wks As Worksheet, ByRef rng As Range, ByRef col As Long)
    
    With wks
        .Cells(.Rows.count, col).End(xlUp).Offset(1, -1).Resize(rng.Rows.count, rng.Columns.count).Value = rng.Value
    End With


End Sub

Wow! JackDanIce, 100% perfect!! I appreciate your time for solving this

I am Sorry for causing you a trouble

Thank you so much!! For fulfilling my second request

Good Luck

Kind regards,
Kishan

 

[JackDanIce]

You're welcome