I would like to track the progress of my program. I'm not sure why but sometimes my code can't finish to the end and the excel went not-responding. Here is my code:
/////////////////////////////////////////////////////////////////////////////////////
Dim LastRow As Long
LastRow = Worksheets("SETList rearranged").Range("D" & Application.Rows.Count).End(xlUp).Row
'start main code
'For Each Cell In Worksheets("SETList rearranged").Range("D1:D10") //test run 10 companies
For Each Cell In Worksheets("SETList rearranged").Range("D1:D" & LastRow)
Sheets("HL input").Select
With Selection.QueryTable
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
End With
With ActiveWorkbook.Connections("Connection")
.Name = "Connection"
.Description = ""
End With
ActiveCell.Range("A1:AV69").Select
With Selection.QueryTable
.Connection = "URL;http://www.set.or.th/set/companyhighlight.do?symbol=" & Cell.Value
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("A1:AV69").Select
ActiveWorkbook.Connections("Connection").Refresh
Sheets("HL rearranged").Select
ActiveCell.Range("A1:F25").Select
Selection.Copy
Sheets("Database").Select
ActiveCell.Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, -4).Range("A1").Select
ActiveCell.Value = Cell.Value
ActiveCell.Offset(26, 4).Range("A1").Select
Next Cell
'COPY FORMAT ///////////////
Dim i As Long
i = 0
Sheets("Database").Select
ActiveCell.Range("F1:K25").Select
Selection.Copy
ActiveCell.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Dim LastRow As Long
LastRow = Worksheets("SETList rearranged").Range("D" & Application.Rows.Count).End(xlUp).Row
For i = 0 To LastRow
ActiveCell.Offset(26, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next i
Application.ScreenUpdating = True
MsgBox "Run Completed"
///////////////////////////////////////////////////////////////////////////////////////////////
I have a list of almost 700 companies that I would like to get their data. The program works fine if I run the program 7 times (100 companies each). However, when I try to do all 700 companies at once, sometimes it went not-responding.
If there's a solution to it that would be great but if not then I would like to simply track the progress of the code. Maybe creating a text file in the same folder and update the current loop it's running. Or any other method is fine as well.
Thank you very much!
/////////////////////////////////////////////////////////////////////////////////////
Dim LastRow As Long
LastRow = Worksheets("SETList rearranged").Range("D" & Application.Rows.Count).End(xlUp).Row
'start main code
'For Each Cell In Worksheets("SETList rearranged").Range("D1:D10") //test run 10 companies
For Each Cell In Worksheets("SETList rearranged").Range("D1:D" & LastRow)
Sheets("HL input").Select
With Selection.QueryTable
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
End With
With ActiveWorkbook.Connections("Connection")
.Name = "Connection"
.Description = ""
End With
ActiveCell.Range("A1:AV69").Select
With Selection.QueryTable
.Connection = "URL;http://www.set.or.th/set/companyhighlight.do?symbol=" & Cell.Value
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("A1:AV69").Select
ActiveWorkbook.Connections("Connection").Refresh
Sheets("HL rearranged").Select
ActiveCell.Range("A1:F25").Select
Selection.Copy
Sheets("Database").Select
ActiveCell.Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, -4).Range("A1").Select
ActiveCell.Value = Cell.Value
ActiveCell.Offset(26, 4).Range("A1").Select
Next Cell
'COPY FORMAT ///////////////
Dim i As Long
i = 0
Sheets("Database").Select
ActiveCell.Range("F1:K25").Select
Selection.Copy
ActiveCell.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Dim LastRow As Long
LastRow = Worksheets("SETList rearranged").Range("D" & Application.Rows.Count).End(xlUp).Row
For i = 0 To LastRow
ActiveCell.Offset(26, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next i
Application.ScreenUpdating = True
MsgBox "Run Completed"
///////////////////////////////////////////////////////////////////////////////////////////////
I have a list of almost 700 companies that I would like to get their data. The program works fine if I run the program 7 times (100 companies each). However, when I try to do all 700 companies at once, sometimes it went not-responding.
If there's a solution to it that would be great but if not then I would like to simply track the progress of the code. Maybe creating a text file in the same folder and update the current loop it's running. Or any other method is fine as well.
Thank you very much!