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
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
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.
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.