Looping macro

[davidnew3754]

I was wondering if someone could help me with my code. I'm a very basic vb user and have the following code. I'd like to know if there was a way of cleaning it up a little rather than using IF statements. I've tried using the go to next blank row and loopoing but as it contains formula it just goes to the very end row, if that makes sense?

Sub transftobdx()
'
Sheets("BDX").Select
If Range("A2") = "Obelisk Open Market - Victoria" Then
Range("A2:AR2").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A3") = "Obelisk Open Market - Victoria" Then
Range("A3:AR3").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A4") = "Obelisk Open Market - Victoria" Then
Range("A4:AR4").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A5") = "Obelisk Open Market - Victoria" Then
Range("A5:AR5").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A7") = "Obelisk Open Market - Victoria" Then
Range("A7:AR7").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A8") = "Obelisk Open Market - Victoria" Then
Range("A8:AR8").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
If Range("A9") = "Obelisk Open Market - Victoria" Then
Range("A9:AR9").Select
Selection.Copy
Windows("Bdx Blank.xlsx").Activate
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(2).Activate
End If
ActiveWorkbook.Close
End Sub


Any assistance greatly appreciated as otherwise I will have an IF statement with 40 + IFs! Many thanks

David

 

[Andrew Poulsom]

What's the name of the worksheet in Bdx Blank.xlsx?

 

[davidnew3754]

Thanks for your quick response. It is just called sheet1

 

[Andrew Poulsom]

Try the untested:

Sub transftobdx()
    Dim Cell As Range
    For Each Cell In Worksheets("BDX").Range("A2:A9")
        If Cell.Value = "Obelisk Open Market - Victoria" Then
            Cell.Resize(, 44).Copy
            With Workbooks("Bdx Blank.xlsx").Worksheets("Sheet1")
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            End With
        End If
    Next Cell
    ActiveWorkbook.Close
End Sub

 

[p45cal]

I've made some assumption so test:

Sub transftobdx()
Set Destn = Workbooks("Bdx Blank.xlsx").Sheets("Sheet1[COLOR=Red][/COLOR]").Cells(Rows.Count, 1).End(xlUp).Offset(1)
For Each cll In Sheets("BDX").Range("A2:A9").Cells
  If cll.Value = "Obelisk Open Market - Victoria" Then
    cll.Resize(, 44).Copy Destn
    Set Destn = Destn.Offset(1)
  End If
Next cll
ActiveWorkbook.Close
End Sub

 

[davidnew3754]

Fantastic. Thank you very much. I hope I'm not in breach of any rules but do you mind if I ask what this line means? As I say I'm only a novice but if I can understand it might help me in the future.


Cell.Resize(, 44).Copy

 

[Peter_SSs]

Another possible approach to try (non-looping)

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> transftobdx_v2()<br>    <SPAN style="color:#00007F">Dim</SPAN> wsBDX <SPAN style="color:#00007F">As</SPAN> Worksheet, wsSh1 <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <br>    <SPAN style="color:#00007F">Set</SPAN> wsBDX = Sheets("BDX")<br>    <SPAN style="color:#00007F">Set</SPAN> wsSh1 = Workbooks("Bdx Blank.xlsx").Sheets("Sheet1")<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> wsBDX.UsedRange<br>        .AutoFilter Field:=1, Criteria1:="=Obelisk Open Market - Victoria"<br>        .Offset(1).Copy<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    wsSh1.Range("A" & wsSh1.Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:= _<br>        xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=<SPAN style="color:#00007F">False</SPAN><br>    wsBDX.AutoFilterMode = <SPAN style="color:#00007F">False</SPAN><br>    Application.CutCopyMode = False<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[p45cal]

Fantastic. Thank you very much. I hope I'm not in breach of any rules but do you mind if I ask what this line means? As I say I'm only a novice but if I can understand it might help me in the future.


cell.Resize(, 44).Copy

It's shorthand in this case for
cell.resize(1,44)
where cell is a single cell, but the range gets resized:
cell(new rows dimension, new columns dimension)

The missing 1 in this case is the original rows dimension of cell.

So if you had:
Range("A2:A4").resize(,22).Select
the resultant selected range would be A2:V4, still 3 rows deep, but 22 columns across.

 

[davidnew3754]

Excellent thank you and thank you to Peter for the alternative. I look forward to making use of this macro in the future it will certainly save a lot of time.

One final thing that would be of use would be when the user selects the macro if it were to ask them to save what is currently bdx Blank as soon as the macro runs. Then when it switches between the windows it knows to refer to the newly saved name as opposed to bdx blank

In step mode somthing like

Sub transftobdx2()
ActiveWorkbook.SaveAs
InputBox ("Select filename")
3. Then run the rest of the macro but replace Bdx.Blank.xls with the saved filename. Is this possible?

Dim Cell As Range
For Each Cell In Worksheets("BDX").Range("A2:A42")
If Cell.Value = "Obelisk Open Market - Victoria" Then
Cell.Resize(, 44).Copy
With Workbooks("Bdx Blank.xlsx").Worksheets("Sheet1")
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End If
Next Cell
ActiveWorkbook.Close
End Sub


Thanks again