hobbiton73
03-08-2013, 09:49 AM
Hi,
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
Columns("A:S").EntireColumn.AutoFit
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
Next
'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
Chris
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
Columns("A:S").EntireColumn.AutoFit
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
Next
'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
Chris