How to feed data back while running the code?

[nontbita]

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!

 

[Andrew Poulsom]

How many QueryTables do you have in your workbook? Why are you doing this inside the loop (multiple times)?

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

 

[nontbita]

I'm sorry but the code was copied from Macros recording.

My intention is to copy the table is this page, for example this "CPN" company, The Stock Exchange of Thailand : Companies/Securities in Focus

After excel pulled data from the page, I got one table but the cells arrangement is all wrong. So I created another table (in another sheet) to rearrange the cells and copy this to another sheet. Then I loop 700 times.

 

[Andrew Poulsom]

What cell is active on worksheet "Database" when you run your code? That is, where do you want to start pasting the data from worksheet "HL rearranged"?

 

[nontbita]

The starting cell is F1 on the "Database" sheet.

 

[Andrew Poulsom]

Does this work for you (untested):

Sub Test()
    Dim LastRow As Long
    Dim r As Long
    Dim Cell As Range
    LastRow = Worksheets("SETList rearranged").Range("D" & Application.Rows.Count).End(xlUp).Row
    r = 1
    Application.ScreenUpdating = False
    For Each Cell In Worksheets("SETList rearranged").Range("D1:D" & LastRow)
        With Sheets("HL input").QueryTables(1)
            .Connection = "URL;http://www.set.or.th/set/companyhighlight.do?symbol=" & Cell.Value
            .Refresh BackgroundQuery:=False
        End With
        Sheets("HL rearranged").Range("A1:F25").Copy
        Sheets("Database").Range("F" & r).PasteSpecial Paste:=xlPasteValues
        Sheets("Database").Range("A1:F25").Copy
        Sheets("Database").Range("F" & r).PasteSpecial Paste:=xlPasteFormats
        r = r + 26
    Next Cell
    Application.ScreenUpdating = True
    MsgBox "Run Completed"
End Sub

 

[nontbita]

I'm outside now but will get back to test it asap. Thank you very much!

 

[nontbita]

The code works great!

However, I found that the not-responding still occurred sometimes and in different timing during the run. So I guess the problem is outside the code.

The code actually runs smoothly if I split all 700 companies into, for example, 7 parts. So I'm trying to find another command to delay/wait between each smaller run.