VBA for aProgress bar and SaveAs csv

KasangoJS

New Member
Joined
Mar 14, 2021
Messages
40
Office Version
  1. 2016
  2. 2013
  3. 2010
Platform
  1. Windows
Hi, I have managed to put together the below VBA code from the Champs at Mr. Excel over time and it is working beautifully. Basically it prompts the user to select a folder, then it runs through all *.xls* files, if they contain a "Master" sheet it merges all of them using the headers and then it saves as a CSV. Two issues:
1) Some folders have many files, so the user does not know whether to get up and go for a cup of coffee or the system has hanged! I need a Progress bar showing % and time remaining!
2) towards the bottom I find that I have to name the CSV file and manually insert the .CSV. I wish it could just pick the folderName+"MasterStack.CSV"

A million Thanks in Advance!
Here is the code (sorry it is a bit dirty-I am a novice):


VBA Code:
Sub ImportFiles3()
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, Head As Range
Dim xStrAWBName As String, FolderName As String, sItem As String, Header As Long
Dim FolderPath As String, fldr As FileDialog, Lr As Long, LCD As Long, R As Long
Dim os As Long, LrS As Long, LCS As Long, FileName As String
On Error Resume Next
Set xTWB = ThisWorkbook
Worksheets.Add
Set DestSheet = xTWB.ActiveSheet

  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder containing files to merge"
        .AllowMultiSelect = False
        '.InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
   
NextCode:

    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = "Master" Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
LrS = xWS.Range("A" & Rows.Count).End(xlUp).Row
LCS = xWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
LCD = DestSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Lr = 1 Then
Range(DestSheet.Cells(0, 2), DestSheet.Cells(2, LCS)).Value = Range(xWS.Cells(1, 1), xWS.Cells(2, LCS - 1)).Value
DestSheet.Range("A1").Value = "FileName"
End If
     Set Head = xWS.Range("A1")
       For os = 0 To xWS.Cells(2, Columns.Count).End(xlToLeft).Column - 1
            On Error Resume Next
            Header = 0
            Header = WorksheetFunction.Match(Head.Offset(0, os), DestSheet.Rows(1), 0)
            On Error GoTo 0
          
            If Header = 0 Then
                DestSheet.Cells(1, LCD) = Head.Offset(0, os)
                Header = LCD
                LCD = LCD + 1
            End If
    If Lr = 1 Then
      Range(DestSheet.Cells(Lr + 2, Header), DestSheet.Cells(Lr + LrS - 1, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
    Else
      Range(DestSheet.Cells(Lr + 1, Header), DestSheet.Cells(Lr + LrS - 2, Header)).Value = Range(xWS.Cells(3, os + 1), xWS.Cells(LrS, os + 1)).Value
    End If
     Next os
     If Lr = 1 Then
     Range(DestSheet.Cells(Lr + 2, 1), DestSheet.Cells(Lr + LrS - 1, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
     Else
     Range(DestSheet.Cells(Lr + 1, 1), DestSheet.Cells(Lr + LrS - 2, 1)).Value = Left(FileName, Application.WorksheetFunction.Find(".", FileName) - 1)
     End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop

DestSheet.Activate
DestSheet.Name = "xStrAWBName"
Rows("2:2").Select
Selection.AutoFilter
ActiveWindow.FreezePanes = True
Columns("A:EA").EntireColumn.AutoFit

xTWB.Save
Application.StatusBar = False
Sheets("xStrAWBName").Select
    Sheets("xStrAWBName").Move
    ActiveWorkbook.SaveAs FileName:=Application.GetSaveAsFilename(""), FileFormat:=xlCSV, CreateBackup:=False

MsgBox "MasterStack DONE for " & xStrAWBName & vbLf & vbLf _
    & "Please SIFT THE DATA - NO PLANTING DATE- OUT!", vbInformation

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Last edited by a moderator:

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

Watch MrExcel Video

Forum statistics

Threads
1,129,589
Messages
5,637,278
Members
416,963
Latest member
samfuge

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top