循环遍历行，当为空时移动到下一列 - vba

Question

I've been spending days in trying to figure out how I need to do this but just can't find it. Hope some one is kind enough to help me out. The goal of this script is to get a table from a website and put them in a table in Excel.

But I need 6 (For the time being. In the future this will be more than 26 different tables) different tables and I don't want to make a sub for each table request. So I put all the variable data on Sheet1 of my file.

The idea is that my script goes over each column and gets the table that I need until there is an empty column. To get this data for 1 column isn't an issue as this is working. The issue is that I just can't figure out how I can move on to column B, column C, ... until there is an empty column.

I've been trying every single thing that I found online, but nothing seem to get it going. If somebody can help me out or give me clear pointers how to do that would be very much appreciated.

Sub ImportTBL1()
    
    Dim sourceSheet As Worksheet
    Dim QT As QueryTable
    Dim destCell As Range
    Dim qtResultRange As Range
    Dim TBL As String
    Dim URL As String
    Dim DES As String
    Dim COL As String
    
    Set sourceSheet = Sheet6
    Dim rng As Range: Set rng = Application.Range("Sheet1!A1")
    Dim cel As Range
        
        For Each cel In rng.Cells
            TBL = rng.Cells(1)
            URL = rng.Cells(2)
            DES = rng.Cells(3)
            COL = rng.Cells(4)
        Next cel
         
    With sourceSheet
        Set destCell = .Range(DES)
        On Error Resume Next
        .ListObjects(TBL).Delete
        On Error GoTo 0
    End With
    
    Set QT = destCell.Worksheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=destCell)
    
    With QT
        .RefreshStyle = xlOverwriteCells
        .WebFormatting = xlNone
        .WebSelectionType = xlSpecifiedTables
        .WebTables = COL
        .BackgroundQuery = False
        .Refresh
        Set qtResultRange = .ResultRange
        .Delete
    End With
    
    With destCell
        .Worksheet.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = TBL
        sourceSheet.ListObjects(TBL).ShowAutoFilterDropDown = False
    End With

End Sub

Answer 1

You did not answer the clarification question, but looking at your code I (only suppose) that your code needs only the first 5 rows of each column to be processed. At least, the following code is based on the above described assumption. Please, test it and send some feedback:

Sub ImportTBL1()
    Dim sourceSheet As Worksheet, QT As QueryTable, destCell As Range
    Dim qtResultRange As Range, TBL As String, URL As String
    Dim DES As String, COL As String, colsNo As Long, i As Long
    
    Set sourceSheet = Sheet6: colsNo = 6 'use here the number of columns to be processed
    Dim rng As Range, cel As Range
    
    For i = 1 To colsNo
        Set rng = Sheet1.cells(1, i).Value
            
            For Each cel In rng.cells
                TBL = rng.cells(1)
                URL = rng.cells(2)
                DES = rng.cells(3)
                COL = rng.cells(4)
            Next cel
             
        With sourceSheet
            Set destCell = .Range(DES)
            On Error Resume Next
            .ListObjects(TBL).Delete
            On Error GoTo 0
        End With
        
        Set QT = destCell.Worksheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=destCell)
        
        With QT
            .RefreshStyle = xlOverwriteCells
            .WebFormatting = xlNone
            .WebSelectionType = xlSpecifiedTables
            .WebTables = COL
            .BackgroundQuery = False
            .Refresh
            Set qtResultRange = .ResultRange
            .Delete
        End With
        
        With destCell
            .Worksheet.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = TBL
            sourceSheet.ListObjects(TBL).ShowAutoFilterDropDown = False
        End With
    Next i
End Sub

Answer 2

I will just add some context around @FaneDuru's answer and to also help the OP with some understanding about how to approach the problem.

Essentially all you need to do is wrap your code in a For loop - as you have a specific task that you want to repeat across independent columns.

In VBA, you have the option of either using a For Each loop or a For Next loop. Each has their benefits and use and I suppose each could be used in this case. That being said, I would prefer the For Next loop because that would mean I no longer need a Range object to loop through using the For Each approach.

Approach 1: For Next

Sub ImportTBL1()

    Dim sourceSheet As Worksheet, QT As QueryTable, destCell As Range
    Dim qtResultRange As Range, TBL As String, URL As String
    Dim DES As String, COL As String
    Dim iCols As Long
    
    Set sourceSheet = Sheet6
    iCols = Sheets("Sheet1").Range("A1").End(xlToRight).Column
    
    For i = 1 To iCols

        TBL = Sheets("Sheet1").Cells(1,i).Value
        URL = Sheets("Sheet1").Cells(2,i).Value
        DES = Sheets("Sheet1").Cells(3,i).Value
        COL = Sheets("Sheet1").Cells(4,i).Value
             
        With sourceSheet
            Set destCell = .Range(DES)
            On Error Resume Next
            .ListObjects(TBL).Delete
            On Error GoTo 0
        End With
        
        Set QT = destCell.Worksheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=destCell)
        
        With QT
            .RefreshStyle = xlOverwriteCells
            .WebFormatting = xlNone
            .WebSelectionType = xlSpecifiedTables
            .WebTables = COL
            .BackgroundQuery = False
            .Refresh
            Set qtResultRange = .ResultRange
            .Delete
        End With
        
        With destCell
            .Worksheet.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = TBL
            sourceSheet.ListObjects(TBL).ShowAutoFilterDropDown = False
        End With
    Next i
End Sub

Approach 2: For Each

Sub ImportTBL1()

    Dim sourceSheet As Worksheet, QT As QueryTable, destCell As Range
    Dim qtResultRange As Range, TBL As String, URL As String
    Dim DES As String, COL As String
    Dim iCols As Long
    
    Set sourceSheet = Sheet6
    iCols = Sheets("Sheet1").Range("A1").End(xlToRight).Column
    Dim rng As Range: cel As Range
    
    With Sheets("Sheet1")
        Set rng = .Range(.Cells(1, 1), .Cells(1,iCols))
    End With

    For Each cel in rng
        
        TBL = cel.Value
        URL = cel.Offset(1,0).Value
        DES = cel.Offset(2,0).Value
        COL = cel.Offset(3,0).Value

        With sourceSheet
            Set destCell = .Range(DES)
            On Error Resume Next
            .ListObjects(TBL).Delete
            On Error GoTo 0
        End With
        
        Set QT = destCell.Worksheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=destCell)
        
        With QT
            .RefreshStyle = xlOverwriteCells
            .WebFormatting = xlNone
            .WebSelectionType = xlSpecifiedTables
            .WebTables = COL
            .BackgroundQuery = False
            .Refresh
            Set qtResultRange = .ResultRange
            .Delete
        End With
        
        With destCell
            .Worksheet.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = TBL
            sourceSheet.ListObjects(TBL).ShowAutoFilterDropDown = False
        End With
    Next cel
End Sub

I have not tested either of the above but you should hopefully get the picture. I will leave it up to you to do further research as to each approach.

Answer 3

I have found it. Finally.

Here's the working script. Maybe someone can use it in the future. Thank you all for the help.

    Sub ImportTBL1()
   
    Dim sourceSheet As Worksheet
    Dim QT As QueryTable
    Dim destCell As Range
    Dim qtResultRange As Range
    Dim TBL As String
    Dim URL As String
    Dim DES As String
    Dim COL As String
   
    Set sourceSheet = Sheet6
    Dim rng As Range:
    
    'Loop through each used cell in row 1
    For Each rng In Sheets("Sheet1").Range("A1", Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft))
    'Dim cel As Range
       
        'For Each cel In rng.Cells   'rng is only one cell. No need to loop through one cell
            TBL = rng.Cells(1, 1)
            URL = rng.Cells(2, 1)
            DES = rng.Cells(3, 1)
            COL = rng.Cells(4, 1)
        'Next cel
             
         With sourceSheet
             Set destCell = .Range(DES)
             On Error Resume Next
             .ListObjects(TBL).Delete
             On Error GoTo 0
         End With
        
         Set QT = destCell.Worksheet.QueryTables.Add(Connection:="URL;" & URL, Destination:=destCell)
        
         With QT
             .RefreshStyle = xlOverwriteCells
             .WebFormatting = xlNone
             .WebSelectionType = xlSpecifiedTables
             .WebTables = COL
             .BackgroundQuery = False
             .Refresh
             Set qtResultRange = .ResultRange
             .Delete
         End With
        
         With destCell
             .Worksheet.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes).Name = TBL
             sourceSheet.ListObjects(TBL).ShowAutoFilterDropDown = False
         End With
         
    Next rng

End Sub