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

Kishan

Well-known Member
Joined
Mar 15, 2011
Messages
1,648
Office Version
  1. 2010
Platform
  1. Windows
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
ABCDEFGHIJKLMNOPQRST
1
2
3
4
5C1C2C3Data1X2
6XSX31S1XSX2SX
726X21
8131611311
9XSX5XXSX1
1011211X52
11X3262X2S2
12161S111
13111111
14262612621
151S1171XSX1
16X11X6X
17112322S2
18X11
19112
2026221
212SX21
2211X6X
231X12X
2411S1
25X522
261S11
2711
2812
2911
3011
3111
3211
3311
342X11X
3521S1
3612
37X12X2
38XSX2
3912
402322
412S21
4211
4312
4412
4511
46X6X1
471S12
4822
4911
5011
512X17X
521
531
541
551
561
57X11X
582S2
591
602
611
621
63X6X
641S1
652
662
672
682
692
701
711
722
732
741
751
762
772
781
791
80X17X
811S1
82X
83
84
85
86
87
Sheet2


Thank you in advance

Regards
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:
Rich (BB code):
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
 
Last edited:
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
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
ABCDEFGH
1
2
3
4
5C1C2C3Data
6XSX3
726
81316
9XSX5
10112
11X3
1216
13111
142626
151S117
16X
171
18X
191
20262
212SX
221
231
241
25X52
261S1
271
281
291
301
311
321
331
342
352
361
37X12X
38XSX
391
40232
412S2
421
431
441
451
46X6X
471S1
482
491
501
512
521
531
541
551
561
57X11X
582S2
591
602
611
621
63X6X
641S1
652
662
672
682
692
701
711
722
732
741
751
762
772
781
791
80X17X
811S1
82X
83
84
Sheet Data


I want the result in sheet1


Book1
ABCDEFGHIJKLMN
1
2
3
4
51X2
61S1XSX2SX
7X21
811311
9XXSX1
1011X52
11262X2S2
121S111
13111
1412621
151XSX1
1611X6X
1712322S2
1811
1912
2021
2121
221X6X
23X12X
241S1
252
261
271
282
291
301
311
321
331
34X11X
351S1
362
372
382
392
402
411
421
432
442
451
461
472
482
491
501
51X17X
52
53
54
Sheet1


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

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

Please could you take a look?

Thank you

Kind Regards,
Kishan
 
Last edited:
Upvote 0
Try:
Code:
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
 
Last edited:
Upvote 0
Try:
Rich (BB code):
Rich (BB code):
Hi JackDanIce, 
 
It is almost perfect may need little touch copy data as shown below and stop at the line below

	
	
	
	
	
	


Code:
 wksSh1.Cells(Rows.Count, c).End(xlUp).Offset(1, -1).Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
Book1
ABCDEFGHIJKLMN
1
2
3
4
51X2
61S1XSX
7X2
81131
9XXSX
1011
11262X
121
131
14262
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
 
Upvote 0
Testing the code, it does fill in all the values, I do not get the same output as above. Try:
Code:
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
 
Upvote 0
Testing the code, it does fill in all the values, I do not get the same output as above. Try:
Code:
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 :)
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top