Help With Looping Macros

[tmsmyer]

I've been piece-mailing together my knowledge of macros based mainly on forums like this and now I finally have a macro that does what I want..mostly. I also understand that explaining my needs is sometimes the hardest part of this, so if my post is lacking clarity, please let me know and I'll try to be more clear.

Right now I have 3 sheets (numbers, query, and main). On Sheet numbers, I have in column B a number in each cell. The amount of cells with numbers changes constantly, but they are always consecutive beginning with cell B2. Right now, my macro checks to see if Sheet Query, cell A1 is blank, if not, then it deletes the contents of the sheet. It then goes to Sheet numbers and checks that cell B2 is not blank, then pulls the number and adds it as a parameter in a url for a web query. (if it is blank it ends the sub) It then runs this query on a Sheet query. It goes onto pull data from this web query and place it on sheet main, cell C2

After it pulls this data I have repeated the macro to do the same for cell B3 (and cell C3 on the main sheet). it then repeats for B4 (C4), B5 (C5), etc. After 10 cells, I have a ridiculously long macro. I just want to know how to loop the macro after 1 set. Each time it will change the Cells from B1 to B2 to B3 etc. The only part of the macro that needs to change in each loop are the cells B2 on sheet number, and the cells C2 on sheet main, and they need to change by +1 each time.

 

[Andrew Poulsom]

You can loop like this:

Sub Test()
    Dim Cell As Range
    With ActiveSheet
        For Each Cell In .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
'           Your code to process the Cell here
        Next Cell
    End With
End Sub

You can use Cell.Offset(0, 1) to refer to the cell in column C.

 

[tmsmyer]

I tried that but it did not work.

Here is my code:

Sub batch1()


Application.ScreenUpdating = False
Sheets("misc").Visible = True
Sheets("batches-rodeo").Visible = True
Sheets("units").Visible = True
Sheets("batches-rodeo").Select
    Range("A:A").Select
    Selection.Delete
Sheets("Batches").Select
Range("B2").Select
    Selection.copy
    Sheets("misc").Select
    Range("C61").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Worksheets("misc").Activate
data_url4 = Range("C63").Value
Worksheets("batches-rodeo").Activate
If Cells(1, 1).Value <> "" Then
Cells.Select
Selection.ClearContents
Selection.Delete Shift:=xlUp
End If


With ActiveSheet.QueryTables.Add(Connection:="URL;" & data_url4, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
 End With


        
Range("M:M").Select
    Selection.copy
    Sheets("units").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
 Sheets("Batches").Select
    Range("J1:L1").Select
    Selection.copy
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Sheets("misc").Visible = False
Sheets("batches-rodeo").Visible = False
Sheets("units").Visible = False
Application.ScreenUpdating = True
End Sub

The parts that I want to change each time are the B2 near the beginning (where it says Range("B2").Select) and the C2 near the end (where it says Range("C2").Select). Everything Else would stay the same

 

[tmsmyer]

Oops, I forgot to add this to the start of the macro code. The B2 in this part also needs to change every time

If ActiveSheet.Range("B2").Value = "" Then Exit Sub

 

[Andrew Poulsom]

Try this (untested):

Sub batch1()
    Dim data_url4 As String
    Dim Cell As Range
    With Sheets("Batches")
        If .Range("B2").Value = "" Then Exit Sub
        Application.ScreenUpdating = False
        For Each Cell In .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
            Sheets("batches-rodeo").Range("A:A").Delete
            Cell.Copy
            Sheets("misc").Range("C61").PasteSpecial Paste:=xlPasteValues
            data_url4 = Worksheets("misc").Range("C63").Value
            With Worksheets("batches-rodeo")
                If .Cells(1, 1).Value <> "" Then
                    .Cells.Delete Shift:=xlUp
                End If
                With .QueryTables.Add(Connection:="URL;" & data_url4, Destination:=Range("A1"))
                    .FieldNames = True
                    .RowNumbers = False
                    .FillAdjacentFormulas = False
                    .PreserveFormatting = True
                    .RefreshOnFileOpen = False
                    .BackgroundQuery = True
                    .RefreshStyle = xlInsertDeleteCells
                    .SavePassword = False
                    .SaveData = True
                    .AdjustColumnWidth = True
                    .RefreshPeriod = 0
                    .WebSelectionType = xlEntirePage
                    .WebFormatting = xlWebFormattingNone
                    .WebPreFormattedTextToColumns = True
                    .WebConsecutiveDelimitersAsOne = True
                    .WebSingleBlockTextImport = False
                    .WebDisableDateRecognition = False
                    .WebDisableRedirections = False
                    .Refresh BackgroundQuery:=False
                End With
                .Range("M:M").Copy
                Sheets("units").Range("A1").PasteSpecial Paste:=xlPasteValues
                Sheets("Batches").Range("J1:L1").Copy
                Cell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
            End With
        Next Cell
        Application.ScreenUpdating = True
    End With
End Sub

Note that I removed all the unnecessary activates and selects.

 

[tmsmyer]

Thanks for removing all the excessive stuff I had in there. The macro appears to work, but it eventually cause excel to become unresponsive. I think it is because it is trying to grab too much from online. I know it works when I run through 10 cycles, so is there a way I can get it to repeat for 10 cycles? (From B2-B12, C2-C12). Or is there another way to make it run better?

 

[Andrew Poulsom]

Is it better if you change the QueryTable's BackgroundQuery property to False?

 

[tmsmyer]

I tried that, and it didn't work either. 10 cycles at a time seem to work just fine, so I just manually went through and added the macro in 10 times. Its long and ugly, but its working. The only problem is instead of having 1 button that would do it all, i now have several buttons (one for each group of 10).