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
1	Select			x	x		x
2		Header 1	Header 2	Header 3	Header 4	Header 5	Header 6	Header 7	Header 8
3	x	1	2	3	4	5	6	7	8
4		11	12	13	14	15	16	17	18
5	x	21	22	23	24	25	26	27	28
6		31	32	33	34	35	36	37	38
7	x	41	42	43	44	45	46	47	48
8		51	52	53	54	55	56	57	58

<tbody>
</tbody>

Sheet1​

--->

Excel 2010

	A	B	C
1	Header 3	Header 4	Header 6
2	3	4	6
3	23	24	26
4	43	44	46

<tbody>
</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