View Full Version : Solved: Status Bar Message With Extract Macro

03-08-2013, 09:49 AM

I wonder whether someone may be able to help me please.

I'm using the code below to successfully merge multiple workbooks into a 'Summary' Sheet.

Sub Merge()
Dim DestWB As Workbook
Dim WB As Workbook
Dim ws As Worksheet
Dim SourceSheet As String
Dim startRow As Long
Dim n As Long
Dim dr As Long
Dim lastRow As Long
Dim FileNames As Variant

Sheets("Input").Range("A7:AE1700, AG7:AG1700").Cells.ClearContents
Set DestWB = ActiveWorkbook

SourceSheet = "Input"
startRow = 7
Application.ScreenUpdating = False

Set WB = ThisWorkbook
FileNames = WB.Worksheets("File List").Range("B4:B20").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1)

Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True)
For Each ws In WB.Worksheets
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Input").Range("C" & DestWB.Worksheets("Input").Rows.Count).End(xlUp).Row + 1
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
If lastRow >= startRow Then
.Range("A" & startRow & ":AE" & lastRow).Copy
DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues
.Range("AG" & startRow & ":AG" & lastRow).Copy
DestWB.Worksheets("Input").Cells(dr, "AG").PasteSpecial xlValues
End If
End If
End With
Exit For
End If
Next ws
Application.CutCopyMode = False
WB.Close savechanges:=False

Next n
Sheets("Resource Summary").Columns("A:AD").EntireColumn.AutoFit
End Sub

Because this macro takes a while to run it's course, I'm trying to implement a 'In Progress Status Bar' message, so that the user knows not to interrupt the extraction process.

Using a solution I've found on the internet as a starting point, I've put together the following script which creates this message.

Sub ShowProgress()

Dim strBar As String
Dim lngLoop As Long
' make StatusBar visible
Application.DisplayStatusBar = True

strBar = String(0, ChrW(&H25A0)) & String(10, ChrW(&H25A1))
Application.StatusBar = strBar & "Starting..."
Application.Wait Now + TimeValue("00:00:01")
For lngLoop = 1 To 8
strBar = String(lngLoop, ChrW(&H25A0)) & String(8 - lngLoop, ChrW(&H25A1))
Application.StatusBar = strBar & " Processing..."
'Application.Wait Now + TimeValue("00:00:01") '<-- Replace this line with your own code to do something
Call Merge

'Relinquish the StatusBar
Application.StatusBar = False

End Sub
You'll see in this code that I call my Extract script via this line: Call Merge
The problem I have is that once the extraction script is run, it then continues in a loop, constantly extacting the files.

I'm sure that it's because I'm calling the extract within the For lngLoop section but If I move it out of this, the status bar message is no longer synced with the extraction of the files.

I've been trying to find a solution for this for sometime now without any success.

I just wondered whether someone could possibly take a look at this please and let me know where I'm going wrong.

Many thanks and kind regards


03-08-2013, 10:59 AM
Consider reversing your structure.
Rather than calling Merge from ShowProgress, call a modified ShowProgress from Merge.

I would put the call right after:

For Each ws In WB.Worksheets

indicating which book and sheet is currently being processed.

03-09-2013, 06:57 AM
Hi @GarysStudent, thank you for taking the time to reply to my post.

Thank you also for the solution, which I've been able to implement, and it works perfectly.

Once again many thanks and kind regards


03-09-2013, 06:58 AM
Thanks for the feedback!