Loop through rows and when empty move to next column

Green Squirrel

New Member
Joined
Jan 9, 2021
Messages
25
Office Version
  1. 365
Platform
  1. MacOS
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.

Screenshot 2021-01-13 at 14.47.27.png


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.

Script

VBA Code:
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, 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

End Sub
 

Some videos you may like

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,376
Try this (not tested).

VBA Code:
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
 

Green Squirrel

New Member
Joined
Jan 9, 2021
Messages
25
Office Version
  1. 365
Platform
  1. MacOS
Try this (not tested).

VBA Code:
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
@AlphaFrog THANK YOU THANK YOU!!! Works brilliantly!!!
 

Green Squirrel

New Member
Joined
Jan 9, 2021
Messages
25
Office Version
  1. 365
Platform
  1. MacOS
Try this (not tested).

VBA Code:
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
Maybe another small question.

in COL I give in the range where the table needs to come, but this I have to calculate manually. The tables don't have a set amount of rows.
So how can I make that the second table come under the first table, with one row between the two tables. As in the picture.
Screenshot 2021-01-13 at 16.23.54.png
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,376
VBA Code:
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 destCell = sourceSheet.Range("B2") 'first Table
    
    '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)
            COL = rng.Cells(4, 1)
        'Next cel
             
        On Error Resume Next
        sourceSheet.ListObjects(TBL).Delete
        On Error GoTo 0
        
         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
         
         Set destCell = destCell.Offset(sourceSheet.ListObjects(TBL).Range.Rows.Count + 1)
         
    Next rng

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,122,240
Messages
5,595,009
Members
413,958
Latest member
SBM

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top