How to feed data back while running the code?

nontbita

New Member
Joined
Jun 23, 2010
Messages
12
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!
 

Some videos you may like

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Andrew Poulsom

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
How many QueryTables do you have in your workbook? Why are you doing this inside the loop (multiple times)?

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

New Member
Joined
Jun 23, 2010
Messages
12
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

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
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

New Member
Joined
Jun 23, 2010
Messages
12

ADVERTISEMENT

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

Andrew Poulsom

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
Does this work for you (untested):

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

New Member
Joined
Jun 23, 2010
Messages
12
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,108,786
Messages
5,524,865
Members
409,606
Latest member
TRINBB

This Week's Hot Topics

Top