VBA code to repeat the code on different rows

[petaaalouise]

Hey,

I've got a code written to transfer the exact data I want from each row. How do I apply this to multiple rows as there is about 300 rows I need to go threw.

Range ("B5").Select
Selection.Copy
Sheets ("TemplateTrans").Select
Range("B16").Select
ActiveSheet. Paste
Sheets ("Master").Select
Range("C5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets ("TemplateTrans").Select
Range("C16").Select
ActiveSheet.Paste
Sheets ("Master").Select
Range ("D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets ("TemplateTrans").Select
Range ("A16").Select
ActiveSheet.Paste
Sheets ("Master").Select
ActiveSheet.Shapes.Range (Array (check Box 84")).Select
Application.CutCopyMode =False
Selection.OnAction = "Macro2"


I'm also using a check box for each row as some rows are not required in the new sheet. Is there a way I can go without writing 300 codes??


Please help

 

[StephenCrump]

You can copy a range in one go, like this:

Sheets("Sheet1").Range("B5:D5").Copy Destination:=Sheets("TemplateTrans").Range("B16")

or if you just want values

Sheets("TemplateTrans").Range("B16:D16").Value = Sheets("Sheet1").Range("B5:D5").Value

(I'm not sure if D5 --> A16 was a typo, the code above assumes D5 ---> D16).

If you have 300 checkboxes, there are ways around writing 300 sets of code. But why do you need a checkbox on each line? Do you want to copy just the lines selected randomly by the user, or can they be filtered in some way automatically?

 

[petaaalouise]

So i have a master spread sheet which has all my info in it. But i want to be able to go through and select certain rows and only specific columns in that row to transfer to a new spreadsheet.

So the code was just for the first row and i need to apply it to all rows in the master. So when I click on the box only that information will go onto the new spreadsheet

 

[StephenCrump]

Here's one way you might do it:

Excel 2010

	A	B	C	D	E	F	G	H	I

<tbody>
[TD="align: center"]1[/TD]
[TD="bgcolor: #FFFF00, align: center"]Select[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]

[TD="align: center"]2[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="align: center"]Header 1[/TD]
[TD="align: center"]Header 2[/TD]
[TD="align: center"]Header 3[/TD]
[TD="align: center"]Header 4[/TD]
[TD="align: center"]Header 5[/TD]
[TD="align: center"]Header 6[/TD]
[TD="align: center"]Header 7[/TD]
[TD="align: center"]Header 8[/TD]

[TD="align: center"]3[/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]4[/TD]
[TD="align: center"]5[/TD]
[TD="align: center"]6[/TD]
[TD="align: center"]7[/TD]
[TD="align: center"]8[/TD]

[TD="align: center"]4[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="align: center"]11[/TD]
[TD="align: center"]12[/TD]
[TD="align: center"]13[/TD]
[TD="align: center"]14[/TD]
[TD="align: center"]15[/TD]
[TD="align: center"]16[/TD]
[TD="align: center"]17[/TD]
[TD="align: center"]18[/TD]

[TD="align: center"]5[/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="align: center"]21[/TD]
[TD="align: center"]22[/TD]
[TD="align: center"]23[/TD]
[TD="align: center"]24[/TD]
[TD="align: center"]25[/TD]
[TD="align: center"]26[/TD]
[TD="align: center"]27[/TD]
[TD="align: center"]28[/TD]

[TD="align: center"]6[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="align: center"]31[/TD]
[TD="align: center"]32[/TD]
[TD="align: center"]33[/TD]
[TD="align: center"]34[/TD]
[TD="align: center"]35[/TD]
[TD="align: center"]36[/TD]
[TD="align: center"]37[/TD]
[TD="align: center"]38[/TD]

[TD="align: center"]7[/TD]
[TD="bgcolor: #FFFF00, align: center"]x[/TD]
[TD="align: center"]41[/TD]
[TD="align: center"]42[/TD]
[TD="align: center"]43[/TD]
[TD="align: center"]44[/TD]
[TD="align: center"]45[/TD]
[TD="align: center"]46[/TD]
[TD="align: center"]47[/TD]
[TD="align: center"]48[/TD]

[TD="align: center"]8[/TD]
[TD="bgcolor: #FFFF00, align: center"][/TD]
[TD="align: center"]51[/TD]
[TD="align: center"]52[/TD]
[TD="align: center"]53[/TD]
[TD="align: center"]54[/TD]
[TD="align: center"]55[/TD]
[TD="align: center"]56[/TD]
[TD="align: center"]57[/TD]
[TD="align: center"]58[/TD]

</tbody>

Sheet1​

--->

Excel 2010

	A	B	C

<tbody>
[TD="align: center"]1[/TD]
[TD="align: center"]Header 3[/TD]
[TD="align: center"]Header 4[/TD]
[TD="align: center"]Header 6[/TD]

[TD="align: center"]2[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]4[/TD]
[TD="align: center"]6[/TD]

[TD="align: center"]3[/TD]
[TD="align: center"]23[/TD]
[TD="align: center"]24[/TD]
[TD="align: center"]26[/TD]

[TD="align: center"]4[/TD]
[TD="align: center"]43[/TD]
[TD="align: center"]44[/TD]
[TD="align: center"]46[/TD]

</tbody>

Sheet2​

using code:

Sub CopyRowsAndCols()

    Dim rng As Range, rngRows As Range, rngCols As Range
    Dim i As Long, lRows As Long, lCols As Long
    
    Set rng = Range("B2:I8") 'Should use range names or dynamic references
    Set rngRows = rng.Rows(1)
    For i = 1 To rng.Rows.Count
        If Sheets("Sheet1").Range("A2:A8")(i).Value = "x" Then
            Set rngRows = Union(rngRows, rng.Rows(i))
            lRows = lRows + 1
        End If
    Next i
    For i = 1 To rng.Columns.Count
        If Sheets("Sheet1").Range("B1:I1")(i).Value = "x" Then
            lCols = lCols + 1
            If rngCols Is Nothing Then
                Set rngCols = rng.Columns(i)
            Else
                Set rngCols = Union(rngCols, rng.Columns(i))
            End If
        End If
    Next i
    
    If lRows = 0 Or lCols = 0 Then
        MsgBox "Please specify at least one row/column"
    Else
        On Error Resume Next
            Range("MyCopiedRange").Clear
        On Error GoTo 0
        With Sheets("Sheet2")
            Intersect(rngRows, rngCols).Copy Destination:=.Range("A1")
            .Range("A1").CurrentRegion.Name = "MyCopiedRange"
        End With
    End If
    
End Sub

Someone else can probably suggest a more succinct way to do this?

 

[Worf]

A non looping solution:

Sub Succint()
Dim lr%, r As Range
Range("a:a").AutoFilter
Set r = Range("b2").CurrentRegion
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("a1:a" & lr).AutoFilter 1, "x", xlFilterValues
r.SpecialCells(xlCellTypeVisible).Copy
Range("a" & lr + 3).PasteSpecial xlPasteValues, xlNone, False, True ' transpose
Range("a:a").AutoFilter
Range("a" & lr + 3).CurrentRegion.AutoFilter 1, "x", xlFilterValues
Range("a" & lr + 3).CurrentRegion.SpecialCells(12).Copy
Sheets("Sheet1").Range("a15").PasteSpecial xlPasteValues, xlNone, False, True   ' transpose
End Sub