How to loop my Current VBA Code - vba

I need to modify with loop my existing VBA. I have a part of website link in Column A. I want to dynamic below this line.
ticjername = Sheet1.Range("A1").Value
I need to loop it, because I want to continue this code until data found in Column A.
My Code:
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
Dim ticjername As String
ticjername = Sheet1.Range("A1").Value
mURL$ = "http://www.example.com=" & ticjername
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & mURL, Destination:=Range("B1"))
.Name = " "
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveCell.Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
End Sub

Try below code
Dim rowID As Integer
rowID = 1
Do
'<Your code>
rowID = rowID + 1
Loop Until Sheet1.Cells(rowID, 1).Value = ""
Credit goes to www.stackoverflow.com

Related

I've ran into a syntax error in vba code for an Excel web query based on a table

I am trying to update a Macro that I recorded so that content from the lines in the spreadsheet will update the web query target but have run into a a few errors. I've sorted through several of them but the current issue is a Runtime error. The following is the code for my query:
Sub GetAllPkgInfo()
Sheets("AllPkgs").Select
Range("A2").Select
Do Until ActiveCell.Value = ""
Call PkgInfo1
Loop
End Sub
Sub PkgInfo1()
'
' PkgInfo1 Macro
' Import RHEL package information from RPMFind
'
' Keyboard Shortcut: Ctrl+Shift+D
'
Selection.Copy
Sheets("WebQuery").Select
ActiveSheet.Cells.Clear
Range("$G$1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add( _
Connection:="URL;https://rpmfind.net/linux/rpm2html/search.php?query=" & _
Range("$G$1").Value, Destination:=Range("$A$1"))
.CommandType = 0
.Name = "search.php?query=abrt_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveCell.Offset(1, -5).Range("A1").Select
Selection.Copy
Sheets("AllPkgs").Select
ActiveCell.Offset(0, 1).Range("CombinedPackages[[#Headers],[Column1]]").Select
ActiveSheet.Paste
Sheets("WebQuery").Select
ActiveCell.Cells.Select
Application.CutCopyMode = False
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("AllPkgs").Select
ActiveCell.Offset(1, -1).Range("CombinedPackages[[#Headers],[Column1]]").Select
End Sub
The error message I receive states "Runtime error '1004': Paste Method of Worksheet Class Failed" and highlights the first code instance of
ActiveSheet.Paste
Can anybody help me get straightened out please?
With ActiveSheet.QueryTables.Add( _
Connection:= "URL;https://rpmfind.net/linux/rpm2html/search.php?query=" & _
Range("G1").Value, Destination:=Range("$A$1"))

Replacing parts of an URL with value from a column

I'm trying to download datasheets for horses.
The only variable in the macro is a part of the URL.
I have all the variables (the horses numbers) listed in column "A".
I want to create a new sheet with the information collected from the website, and then collect information again using the numbers (new variable) from next row in column "A".
So far this is the code I have:
Sub Makro1()
'
' Makro1 Makro
'
Dim nummer As String
nummer = Sheets("Ark1").Range("A1:A10")
'
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://195.198.34.45/trav/hast/visa/" & nummer & "/resultat", Destination:=Range _
("$A$1"))
.CommandType = 0
.Name = "resultat"
.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 = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("D:D").Select
ActiveWindow.SmallScroll Down:=21
Columns("E:E").Select
Range("E22").Activate
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Select
Range("D22").Activate
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _
:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="/", _
FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True
End Sub
User sheet trying to describe problem
a proposition on how to handle multiple query, not sure about what you want to do with each result
Sub Makro1()
'
' Makro1 Makro
'
Set ws = ActiveSheet 'sheet containing your numbers in column A
ActiveWorkbook.Worksheets.Add
For Each nummer In ws.Range("A1:A10")
If nummer.Text = "" Then Exit For
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://195.198.34.45/trav/hast/visa/" & nummer.Text & "/resultat", Destination:=Range("$A$1"))
.Name = "resultat"
.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 = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
nummer.Offset(0, 1) = ActiveSheet.Cells(21, 1)
End With
Next
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub

VBA in Excel web data fetching loop

Sub Button1_Click()
Set ws = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Range("A2:P100").ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www6.landings.com/cgi-bin/nph-search_nnr? pass=193800885&&nnumber=" & ws2.Range("E2").Value _
, Destination:=Range("$G$4"))
.Name = "nph-search_nnr?pass=193800885&&nnumber=22A"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "18"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
'Copy to Another sheet
ws.Range("I7").Copy
ws2.Range("A20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ws.Range("I8").Copy
ws2.Range("B20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ws.Range("I6").Copy
ws2.Range("C20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ws.Range("I5").Copy
ws2.Range("D20000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Sheet2").Columns("A:P").AutoFit
End With
End Sub
I wrote that code with help of recorded macro, it gets certain info from the website,
I need to automate that process and after clicking Button_1 it should loop through all existing cell values of column E in Worksheets("Sheet2")(except the header).I am guessing between each loop it should wait until data are fully retrieved and loaded,
that coding is too much for me to handle yet...
Simply in each looped run part of web address ( ws2.Range("E2").Value ) has to be replaced with next row in column in Sheet2 column E
This should do it.
Update: I added Application.ScreenUpdating = False to speed up the macro.
Option Explicit
Sub Button1_Click()
Dim lastRow As Long, x As Long
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Range("D" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
RequeryLandings .Cells(x, "E")
Next
.Columns("A:P").AutoFit
End With
Application.ScreenUpdating = True
End Sub
Sub RequeryLandings(address As String)
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
Range("A2:P100").ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www6.landings.com/cgi-bin/nph-search_nnr? pass=193800885&&nnumber=" & address _
, Destination:=Range("$G$4"))
.Name = "nph-search_nnr?pass=193800885&&nnumber=22A"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "18"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
DoEvents
'Copy to Another sheet
With Worksheets("Sheet2")
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I7")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I8")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I6")
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = ws.Range("I5")
End With
End With
End Sub

How to scrape data from Twitter from multiple URLs in a column of Excel

I need to basically fill two cells in each row with data from the respective URL present in the same row. When the query is made using macro it returns 5 pieces of data out of which I need only two.
I recorded two macros(one to query the page and other to adjust the data pieces i get) and combined them and applied a do while loop.
But it is returning an error in this line - myurl = "URL;" & Tabsheet.Cells(i, 6)
Below is the code:
'
' Macro1 Macro
'
Sheets("Tabsheet").Select
Range("A1").Select
Dim i As Integer, myurl As String
i = 1
Do While i < 102
myurl = "URL;" & Tabsheet.Cells(i, 6)
With ActiveSheet.QueryTables.Add(Connection:= _
myurl, Destination:=ActiveCell.Offset(i, 8))
.Name = "Query" & i
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("H105").Select
Selection.Cut
Range("I104").Select
Selection.Cut
Range("I103").Select
Selection.ClearContents
Range("H102").Select
i = i + 1
Loop
End Sub
Any suggestions will be extremely helpful.
This should work :
myurl = CStr("URL;" & Sheets("Tabsheet").Cells(i, 6))
You can use TabSheet directly as you didn't set it as an object, you could have if you did that before :
Dim TabSheet As Worksheet
Set TabSheet = ThisWorkbook.Sheets("TabSheet")
'------------------------------------
'--------Here come your code---------
'------------------------------------
'And when it's done, don't forget to free what you have set
Set TabSheet = Nothing

Import data from web: repeat loop

I have this VBA script that works:
Sub Basic_Web_Query()
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & ActiveSheet.Range("A2").Value, Destination:=Range("E2"))
.Name = "q?s=goog_2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
I want the macro to do this in a loop, i.e. go to A3 with destination E3, A4 with destination A4... etc.
any help will be appreciated
thansk!
I like to use 'offset' for these loops: OFFSET(rows down, columns right).
Negative values move up and left.
for example:
for p= 1 to 5
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & ActiveSheet.Range("A2").offset(p-1,0).Value, Destination:=Range("E2").offset(p-1,0))
'other code
End With
next p
google 'loop vba' and you will hit plenty of examples. Here's one:
Dim rw As Long
For rw = 1 To 5
Range("E" & rw).Value = Range("A" & rw).Value
'other stuff
Next rw