Greeting!
I have a VBA that is in a Workbook with a Table containing strings for replacement. The VBA logic do the following: Read files in folder Create a separate process Open a file from the folder in that separate process In "Main" and "DataSpreadSheet" Worksheets look and replace values that are present in the Table. Save the separate process workbook under another Repeats the action on the other file in the folder.
This VBA proceeds the way I need, the only problem is that it takes so much time. I have a bunch of files, over 100 to proceed regularly, and each file around 10-15 minutes to proceed, while the data for replacement is in range of B3:BB500 at most, with approximately 40% of cells in the range is actually filled with values.
The code is below, and do you have any suggestion on how to make it proceed faster? I have already disabled all calculations and updates while code is running.
The overall goal for the VBA is to translate Worksheets to another language using provided in Table translated strings arranged in columns for each language
I would appreciate help with rewriting the VBA.
Dim fileCollection As Collection
Sub TraversePath(path As String)
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
currentPath = Dir(path, vbDirectory)
'Explore current directory
Do Until currentPath = vbNullString
Debug.Print currentPath
If Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currentPath
ElseIf Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbNormal) = vbNormal Then
fileCollection.Add path & currentPath
End If
currentPath = Dir()
Loop
'Explore subsequent directories
For Each directory In dirCollection
Debug.Print "---SubDirectory: " & directory & "---"
TraversePath path & directory
Next directory
End Sub
Sub String_Autosubstitution()
'Logic: Find & Replace a list of text/values throughout entire workbook from a table
Dim folderName As String, eApp As Excel.Application, fileName As Variant
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Dim inputRange As Range
Dim Var, s As String, t As String, c As Range
Dim newFolderFullName As String
Dim newfileName As String
Dim LangName As String
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim LangColumn As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
'Dim sws As Worksheet
Dim rg As Range
Dim Add As String
Dim AddStart As String
'Timer count: Remember time when macro starts
StartTime = Timer
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
'Turn off automatic calculation for the VBA conteining Master Workbook
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.ErrorCheckingOptions.BackgroundChecking = False
Application.DisplayAlerts = False
'Select folder in which all files are stored
fDialog.Title = "Select the folder with master files"
fDialog.InitialFileName = Left(currWb.path, InStrRev(currWb.path, "\") - 1)
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'Create a separate Excel process that is invisibile
Set eApp = New Excel.Application: eApp.Visible = True
'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
Set fileCollection = New Collection
TraversePath folderName & "\"
For Each fileName In fileCollection
'Update status bar to indicate progress
Application.StatusBar = "Processing " & fileName
'Open file
Set wb = eApp.Workbooks.Open(fileName:=fileName, ReadOnly:=True)
'Turn off automatic calculation for the Slave Workbook
eApp.Calculation = xlCalculationManual
'eApp.ScreenUpdating = False
eApp.ErrorCheckingOptions.BackgroundChecking = False
eApp.DisplayAlerts = False
'Create variable to point to your table
Set tbl = ThisWorkbook.Sheets("LangLib").ListObjects("LangTable")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Set langauge columnt variable
LangColumn = Application.Workbooks(ActiveWorkbook.Name).Worksheets("Scripts").Range("S6")
'Designate Columns for Find/Replace data
fndList = 1
rplcList = LangColumn
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each ws In wb.Worksheets
If ws.Name = "Main" Or ws.Name = "DataSpreadsheet " Then
'Define and set range on each sheet for execution
Add = ws.Range("B1").SpecialCells(xlCellTypeLastCell).Address
AddStart = ws.Range("B1:" & Add).Address
Set rg = ws.Range(AddStart)
'Loop through each item in Array lists (Array is the library of strigs from LangLib sheet)
For x = LBound(myArray, 1) To UBound(myArray, 2)
If myArray(rplcList, x) <> "" Then
rg.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
On Error Resume Next
Next x
End If
Next ws
'Sets name for file to be saved
LangName = Application.Workbooks(ActiveWorkbook.Name).Worksheets("UI").Range("I37")
newfileName = Left(fileName, Len(fileName) - 5) & LangName & ".xlsx"
eApp.Calculation = xlAutomatic
wb.SaveCopyAs fileName:=newfileName
wb.Close SaveChanges:=False
Debug.Print "Processed " & fileName 'Progress indication
Next fileName
eApp.DisplayAlerts = True
'eApp.Calculation = xlCalculationAutomatic
eApp.ErrorCheckingOptions.BackgroundChecking = True
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.ErrorCheckingOptions.BackgroundChecking = True
Application.DisplayAlerts = True
'Timer: Determines how many seconds code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "Translation completed in " & MinutesElapsed & " minutes", vbInformation
'MsgBox "Translation completed"
End Sub
CodePudding user response：
I have modified the code using approach @ENIAC suggested, yet need to fix error.
Dim fileCollection As Collection
Sub TraversePath(path As String)
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
currentPath = Dir(path, vbDirectory)
'Explore current directory
Do Until currentPath = vbNullString
Debug.Print currentPath
If Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirCollection.Add currentPath
ElseIf Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbNormal) = vbNormal Then
fileCollection.Add path & currentPath
End If
currentPath = Dir()
Loop
'Explore subsequent directories
For Each directory In dirCollection
Debug.Print "---SubDirectory: " & directory & "---"
TraversePath path & directory
Next directory
End Sub
Sub String_Autosubstitution()
'Logic: Find & Replace a list of text/values throughout entire workbook from a table
Dim folderName As String, eApp As Excel.Application, fileName As Variant
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Dim inputRange As Range
Dim Var, s As String, t As String, c As Range
Dim newFolderFullName As String
Dim newfileName As String
Dim LangName As String
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim LangColumn As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
'Dim sws As Worksheet
Dim rangeToCopy As Range
Dim Add As String
Dim AddStart As String
'Timer count: Remember time when macro starts
StartTime = Timer
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
'Turn off automatic calculation for the VBA conteining Master Workbook
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.ErrorCheckingOptions.BackgroundChecking = False
Application.DisplayAlerts = False
'Select folder in which all files are stored
fDialog.Title = "Select the folder with master files"
fDialog.InitialFileName = Left(currWb.path, InStrRev(currWb.path, "\") - 1)
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'Create a separate Excel process that is invisibile
Set eApp = New Excel.Application: eApp.Visible = True
'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
Set fileCollection = New Collection
TraversePath folderName & "\"
For Each fileName In fileCollection
'Update status bar to indicate progress
Application.StatusBar = "Processing " & fileName
'Open file
Set wb = eApp.Workbooks.Open(fileName:=fileName, ReadOnly:=True)
'Turn off automatic calculation for the Slave Workbook
eApp.Calculation = xlCalculationManual
'eApp.ScreenUpdating = False
eApp.ErrorCheckingOptions.BackgroundChecking = False
eApp.DisplayAlerts = False
'Create variable to point to your table
Set tbl = ThisWorkbook.Sheets("LangLib").ListObjects("LangTable")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Set langauge columnt variable
LangColumn = Application.Workbooks(ActiveWorkbook.Name).Worksheets("Scripts").Range("S6")
'Designate Columns for Find/Replace data
fndList = 1
rplcList = LangColumn
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each ws In wb.Worksheets
If ws.Name = "Main" Or ws.Name = "DataSpreadsheet " Then
'Define and set range on each sheet for execution
Add = ws.Range("B1").SpecialCells(xlCellTypeLastCell).Address
AddStart = ws.Range("B1:" & Add).Address
Set rangeToCopy = ws.Range(AddStart)
'--------------new logic-------------
rangeToCopy.Select
Dim arrayFromSheet() As Variant
arrayFromSheet = rangeToCopy
'Loop through each item in Array lists (Array is the library of strigs from LangLib sheet)
For x = LBound(myArray, 1) To UBound(myArray, 2)
If myArray(rplcList, x) <> "" Then
arrayFromSheet.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
' Copy data from 2D array back to sheet.
rangeToCopy.Value = arrayFromSheet
'--------------new logic-------------
End If
On Error Resume Next
Next x
End If
Next ws
LangName = Application.Workbooks(ActiveWorkbook.Name).Worksheets("UI").Range("I37")
newfileName = Left(fileName, Len(fileName) - 5) & LangName & ".xlsx"
eApp.Calculation = xlAutomatic
wb.SaveCopyAs fileName:=newfileName
wb.Close SaveChanges:=False
Debug.Print "Processed " & fileName 'Progress indication
Next fileName
eApp.DisplayAlerts = True
'eApp.Calculation = xlCalculationAutomatic
eApp.ErrorCheckingOptions.BackgroundChecking = True
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.ErrorCheckingOptions.BackgroundChecking = True
Application.DisplayAlerts = True
'Timer: Determines how many seconds code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "Translation completed in " & MinutesElapsed & " minutes", vbInformation
'MsgBox "Translation completed"
End Sub
CodePudding user response：
Will post as an answer, in order to show a code and visualization.
You need a 2D array. This is the same worksheet (table). The difference is that you will have to use numbers when referring to the array's columns and rows (the same as for Cells property where you refer as Cells(row_number, column_number)).
Copy entire range that needs processing from the worksheet to a dynamic array. If you want the rows and column indices in the worksheet and in the array to be the consistent, start your range from the first cell (A1). This way, there will be no need in additional conversion from the worksheet cell indices and the array's ones because first row/column in the worksheet corresponds to the first row/column in the array. For example, array(4, 5) cell in the array refers to Cells(4, 5) cell in the worksheet.
Process the data in the array as required. Than, copy the data from the array back to the worksheet.
' Range that needs processing.
' I suggest starting the range from A1
' this way, the array row and column numbering
' will be the same as for the sheet
Dim rangeToCopy As Range
Set rangeToCopy = Sheet1.Range("A1:S20")
rangeToCopy.Select ' just to show range
' Copy data from sheet to 2D array.
' Note that is must be dynamic and of Variant type.
Dim arrayFromSheet() As Variant
arrayFromSheet = rangeToCopy
' Process needed part of array.
For r = Sheet1.Range("D6").Row To UBound(arrayFromSheet, 1)
For c = Sheet1.Range("D6").Column To UBound(arrayFromSheet, 2)
arrayFromSheet(r, c) = arrayFromSheet(r, c) 1
Next c
Next r
' Copy data from 2D array back to sheet.
rangeToCopy.Value = arrayFromSheet
Hope this helps.