VBA automation error - Invalid forward reference - excel

I have a code that has been running just fine, however, suddenly I am getting the following error:
I get the error in all the old files as well, even after completely shutting down excel. I also tried adding "AccessibilityCplAdmin 1.0 Type Library", which helped at first but doesn't anymore.
The error is in line "dData(dr, 1) = sheet.Name"
Does anyone know how this could be solved?
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Application.AutomationSecurity = msoAutomationSecurityLow
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xlsb*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsb*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
Call Copy_cells(wb_from, new_wb)
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:A100").ClearContents
Next
Sheets("Engine").Range("A1:B100").ClearContents
new_wb.Close SaveChanges:=False
RefreshLink_folder (sFolderPath_new)
IsSuccess = True
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.ScreenUpdating = True
End Sub

Related

Create folders and subfolder and sub text files from excel sheet

hi i'm trying to create a list of folders from an excel sheet and in each folder, it should be a txt file named let's say name.txt and in each of these files it should write wats in column b
pic1
I used this code to create the folders but I need help about creating the txt files
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
I need help generating the text file in each folder
Create Text Files From Worksheet Data
Sub MakeFolders()
Const fRow As Long = 2
Const SubFolderColumn As String = "A"
Const TextColumn As String = "B"
Const TextFileNameCellAddress As String = "B1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim wbPath As String: wbPath = ws.Parent.Path & "\"
Dim TextFileName As String
TextFileName = CStr(ws.Range(TextFileNameCellAddress).Value)
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, SubFolderColumn).End(xlUp).Row
Dim srg As Range: Set srg = ws.Range(ws.Cells(fRow, SubFolderColumn), _
ws.Cells(lRow, SubFolderColumn))
Dim sCell As Range
Dim TextFile As Long
Dim FolderPath As String
Dim SubFolderName As String
Dim FilePath As String
Dim FileText As String
For Each sCell In srg.Cells
SubFolderName = CStr(sCell.Value)
If Len(SubFolderName) > 0 Then
FolderPath = wbPath & SubFolderName & "\"
If Len(Dir(FolderPath, vbDirectory)) = 0 Then
MkDir FolderPath
End If
FilePath = FolderPath & TextFileName
FileText = CStr(sCell.EntireRow.Columns(TextColumn).Value)
' Or (the same):
'FileText = CStr(ws.Cells(sCell.Row, TextColumn).Value)
TextFile = FreeFile
Open FilePath For Output As #TextFile
Print #TextFile, FileText
Close TextFile
End If
Next sCell
MsgBox "Files created.", vbInformation
End Sub
try to use FSO.CreateTextFile:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strPath As String
strPath = "d:\name.txt"
Dim oFile As Object
Set oFile = fso.CreateTextFile(strPath)
oFile.WriteLine "test"
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Sub

VBA loop through excel files in folder

I have a macro that loops through the files in a folder in which the original excel with the macro lies. It then does a bunch of copy paste for each of the files in the folder. The macro works correctly for the first file in the folder, however, it then stops. Does anyone know why this is so (the starts when it says "Get the list of other tabs (column A)")? There are no errors, the macro just stops looping.
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Get the list of other tabs (column A)
Do While Len(sFileName) > 0
If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & sFileName
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & sFileName
End If
sFileName = Dir
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:B100").ClearContents
Loop
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
While it may be difficult to determine why it stops looping by observation/review...code can usually be re-organized to help narrow down where/what the problem is.
Given that it currently stops looping after processing the first file, it is clear that Dir is (for whatever reason) returning an empty string after the first file is processed. A first step to debugging the issue would be to isolate the task of getting all the filepaths. Once all the filepaths are determined, Then operate on each file of interest. This step is implemented in the code below.
If loading the filepaths separately fails, then you have a lot less code to debug. If all the filepaths load successfully and the code still fails, then the problem is within the subsequent loop.
As has been commented, it is possible that the code within the Do While loop is somehow preventing Dir from operating properly. If this is the case, then the code below might get the code to work. If the code still fails after collating the filepaths of interest, then start parsing out blocks of functionality within If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then. Good luck!
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:B100").ClearContents
Next
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
This worked for me in the end if anyone needs the full code. It takes the answer above, and just adjusts some of the variables:
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:A100").ClearContents
Next
Sheets("Engine").range("A1:A100").ClearContents
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub

VBA code to copy paste data from multiple source workbooks to a master data workbook (Master data sheet) based on column headers

My code below browses through the folder and effectively picks out the required files but the copy paste codes that I have tried did not work for me. Cant use traditional copy paste as column order is not same. Column names are same though.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
rowOutputTarget = 2
nameCount = 2
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
'row count based on column 1 = A
rowCountSource = .Cells(.Rows.Count, 1).End(xlUp).Row
'column count based on row 1
colCountSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
-------------------------------Need help here to copy paste-------------------------------------
'copy and paste from A2
wsSource.Range("A3", "AD" & rowCountSource).Copy
wsTarget.Range("A" & rowOutputTarget).PasteSpecial
Paste:=xlPasteValues
bookName.Range("A" & nameCount).Value = wbSource.Name
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
End Sub
Since the order of the columns is different you have to copy them one at a time.
Sub ImportExcelfiles()
Const ROW_COLNAME = 3
'Variables for Sheet - Workbook Name
Dim wbSource As Workbook
Dim wsTarget As Worksheet, wsName As Worksheet
Dim rowOutputTarget As Long, nameCount As Long
Dim strPath As String, strFile As String, fileName As String
With ThisWorkbook
'set the file and path to folder
strPath = .Sheets("Control").Range("C4")
fileName = .Sheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target and name worksheets
Set wsTarget = .Sheets("Master Data")
Set wsName = .Sheets("Workbook Name")
End With
' fill dictionary column name to column number from row 1
Dim dict As Object, k As String, rng As Range
Dim lastcol As Long, lastrow As Long, i As Long, n As Long
Set dict = CreateObject("Scripting.Dictionary")
With wsTarget
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
k = UCase(Trim(.Cells(1, i)))
dict.Add k, i
Next
End With
'set the initial output row and column count for master data and workbook nam
rowOutputTarget = 2
nameCount = 2
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop through the excel files in the folder
Dim ar, arH, ky, bHasData
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, False, False)
wsName.Range("A" & nameCount).Value = wbSource.Name
nameCount = nameCount + 1
' copy values to arrays
With wbSource.Sheets("Details")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
arH = .Range("A1:AD1").Offset(ROW_COLNAME - 1).Value2 ' col names
ar = .Range("A" & ROW_COLNAME & ":AD" & lastrow).Value2
End With
'close the opened workbook
wbSource.Close SaveChanges:=False
' copy each columns
If lastrow > ROW_COLNAME Then
bHasData = False
For n = 1 To UBound(ar, 2)
k = UCase(Trim(arH(1, n)))
' determine target column using dictonary
' as lookup with approx match
i = 0
For Each ky In dict
If InStr(1, k, ky) > 0 Then
i = dict(ky)
Exit For
End If
Next
' valid match
If i > 0 Then
bHasData = True
Set rng = wsTarget.Cells(rowOutputTarget, i).Resize(UBound(ar))
' copy column n of array to column i of target sheet
rng.Value2 = Application.Index(ar, 0, n)
ElseIf Len(k) > 0 Then
Debug.Print "Column '" & k & "' not found " & strFile
End If
Next
If bHasData Then
rowOutputTarget = rowOutputTarget + UBound(ar) + 2
End If
End If
'get the next file
strFile = Dir()
End If
Loop
Application.ScreenUpdating = True
MsgBox nameCount - 2 & " books", vbInformation
End Sub
Import Data From Files in Folder
Option Explicit
Sub ImportExcelfiles()
' Source
Const sName As String = "Details"
Const siFileExtensionPattern As String = ".xlsx" ' maybe ".xls?" ?
Const sfCol As String = "A"
Const slCol As String = "AD"
Const sfRow As Long = 3
' Destination
Const dName As String = "Master Data"
Const dfCellAddress As String = "A2"
' Destination Lookup
Const dlName As String = "Control"
Const dlsFolderPathAddress As String = "C4"
Const dlsFileNamePatternAddress As String = "C5"
' Destination Name
Const dnName As String = "Workbook Name"
Const dnfCellAddress As String = "A2"
Dim dwb As Workbook: Set dwb = ThisWorkbook
' Destination Lookup Worksheet
' (contains the folder path and the partial file name)
Dim dlws As Worksheet: Set dlws = dwb.Worksheets(dlName)
Dim sFolderPath As String: sFolderPath = dlws.Range(dlsFolderPathAddress)
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileNamePattern As String ' contains i.e. leading and trailing '*'
sFileNamePattern = "*" & dlws.Range(dlsFileNamePatternAddress) & "*"
Dim sFileExtensionPattern As String
sFileExtensionPattern = siFileExtensionPattern
If Left(sFileExtensionPattern, 1) <> "." Then _
sFileExtensionPattern = "." & sFileExtensionPattern
Dim sFileName As String
sFileName = Dir(sFolderPath & sFileNamePattern & sFileExtensionPattern)
If Len(sFileName) = 0 Then
MsgBox "No files found.", vbCritical ' improve!
Exit Sub
End If
' Destination Worksheet (source data will by copied to)
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
' Source and Destination Columns Count
Dim cCount As Long
cCount = dws.Columns(slCol).Column - dws.Columns(sfCol).Column + 1
' Destination First Row Range
Dim dfrrg As Range: Set dfrrg = dws.Range(dfCellAddress).Resize(, cCount)
' Destination Name Worksheet (source workbook names will be written to)
Dim dnws As Worksheet: Set dnws = dwb.Worksheets(dnName)
' Destination Name Cell
Dim dnCell As Range: Set dnCell = dnws.Range(dnfCellAddress)
Application.ScreenUpdating = False
' Source
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
' Destination
Dim drg As Range
' Both
Dim rCount As Long
Do While Len(sFileName) > 0
Set swb = Workbooks.Open(sFolderPath & sFileName)
' Attempt to reference the source worksheet.
On Error Resume Next
Set sws = swb.Worksheets("Details")
On Error GoTo 0
If Not sws Is Nothing Then ' worksheet exists
slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
If slRow >= sfRow Then ' found data in column
rCount = slRow - sfRow + 1
Set srg = sws.Cells(sfRow, sfCol).Resize(rCount, cCount)
Set drg = dfrrg.Resize(rCount)
drg.Value = srg.Value
dnCell.Value = swb.Name
' Reset
Set dfrrg = dfrrg.Offset(rCount)
Set dnCell = dnCell.Offset(1)
'Else ' found no data in column; do nothing
End If
Set sws = Nothing
'Else ' worksheet doesn't exist; do nothing
End If
swb.Close SaveChanges:=False
sFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub

Copy a Range from Multiple Sheets in a Different Workbook and Save

I regularly upload an excel file into an automated system. This system requires I use its "template" but I am limited to 1000 entries at a time. I frequently have 80k-100k entries to upload meaning I have to upload this template 80-100 times. I have managed to write a macro that splits my 80k-100k file into sheets containing 1000 enties each. What I have done up till now is then manually copy the range from each sheet into the "template", save the template with a unique name, and repeat until I copy all 80-100 sheets. I know there must be a faster way to loop through the sheets, copy to the "template", and save.
I have managed to get a loop started but it only copies the first sheet x number of times.
Sub CopytoTemp()
Dim lngJ As Long
Dim numSheets As Long
Dim name As String
Dim savePath As String
Dim saveName As String
lngJ = 0
name = "Upload_"
savePath = "Path\"
saveName = "Name_"
'Counts the number of sheets in my big list
numSheets = Workbooks("BigList.xlsx").Sheets.Count
'Loop through each sheet
While lngJ < numSheets
Workbooks("BigList.xlsx").Worksheets(lngJ).Activate
Range("A1:I1000").Select
Selection.Copy
Windows("Template.xlsx").Activate
'The first few columns are optional fields that I do not fill out
Range("E7").Select
ActiveSheet.Paste
'Fills in the upload name field in the template
Workbooks("Template.xlsx").Worksheets("Sheet1").Range("B2").Value = name & CStr(lngJ)
wbICM.SaveAs (savePath & saveName & lngJ & ".xlsx")
Workbooks.Open "Path\Template.xlsx"
lngJ = lngJ + 1
Wend
End Sub
This is what I have been using to split the data
Sub SplitWorksheet()
Dim lngLastRow As Long
Dim lngNumberOfRows As Long
Dim lngI As Long
Dim strMainSheetName As String
Dim currSheet As Worksheet
Dim prevSheet As Worksheet
'Number of rows to split among worksheets
lngNumberOfRows = 1000
'Current worksheet in workbook
Set prevSheet = ActiveWorkbook.ActiveSheet
'First worksheet name
strMainSheetName = prevSheet.Name
'Number of rows in worksheet
lngLastRow = prevSheet.Cells(Rows.count, 1).End(xlUp).Row
'Worksheet counter for added worksheets
lngI = 1
While lngLastRow > lngNumberOfRows
Set currSheet = ActiveWorkbook.Worksheets.Add
With currSheet
.Move after:=Worksheets(Worksheets.count)
.Name = strMainSheetName + "(" + CStr(lngI) + ")"
End With
With prevSheet.Rows(lngNumberOfRows + 1 & ":" & lngLastRow).EntireRow
.Cut currSheet.Range("A1")
End With
lngLastRow = currSheet.Cells(Rows.count, 1).End(xlUp).Row
Set prevSheet = currSheet
lngI = lngI + 1
Wend
End Sub
Please, test the next code and send some feedback:
Sub CopytoTemp()
Dim i As Long, name As String, savePath As String, saveName As String, lastRow As Long, arrC, arrSlice
Dim wbBL As Workbook, ws As Worksheet, wbT As Workbook, nrRows As Long, iCount As Long, strCols As String
Set wbBL = Workbooks("BigList.xlsx")
name = "Upload_": saveName = "Name_"
savePath = ThisWorkbook.Path & "\Path\" 'build here your real path
With Application 'some optimization to make the code faster:
.ScreenUpdating = False: .EnableEvents = False
.Calculation = xlCalculationManual
End With
For Each ws In wbBL.Worksheets 'iterate between all sheets of wbBL workbook
lastRow = ws.Range("A" & ws.rows.Count).End(xlUp).row
arrC = ws.Range("A1:I" & lastRow).Value 'place the whole range in an array
For i = 1 To lastRow
Set wbT = Workbooks.Open(savePath & "Template.xlsx") 'use here the Template full name
strCols = "A:I" 'a string used to determine the columns of the following sliced array
If i >= (lastRow - 1000) Then
nrRows = lastRow - 1001 'calculate number of rows for the last slice on the sheet
Else
nrRows = 999
End If
'extract a slice array of all columns and 1000 (or rest up to the sheet end) rows:
arrSlice = Application.Index(arrC, Evaluate("row(" & i & ":" & i + nrRows & ")"), Evaluate("COLUMN(" & strCols & ")"))
wbT.Worksheets("Sheet1").Range("A1").Resize(UBound(arrSlice), UBound(arrSlice, 2)).Value = arrSlice 'drop the slice array content
iCount = iCount + 1 'increment the files count number
Application.DisplayAlerts = False
wbT.saveas savePath & saveName & iCount & ".xlsx" 'save the workbook (overwriting existing, if the case)
Application.DisplayAlerts = True
wbT.Close False 'close the workbook without saving it
i = i + nrRows 'increment the rows interation variable
Next i
Next
With Application
.ScreenUpdating = True: .EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Ready..."
End Sub
Split by 1000 Records to New Workbooks
A Ton of Workbooks
The code is in an open workbook (e.g. Personal.xlsb).
Opens another file BigList.xlsx and prepares to copy a thousand rows at a time.
Opens another file Template.xlsx and pastes the rows.
Saves it as another file Name_?.xlsx. Closes Template.xlsx.
Repeats under 3 and 4 as needed.
Closes BigList.xlsx.
Carefully adjust the values in the constants section (especially the paths).
Option Explicit
Sub CopytoTemp()
' Source
Const swbPath As String = "C:\Test\2022\70701660\" ' ?
Const swbName As String = "BigList.xlsx"
Const swsID As Variant = 1 ' or "Sheet1" ?
Const sfRow As Long = 1
Const sCols As String = "A:I"
Const sRows As Long = 1000
' Destination
Const dPath As String = "C:\Test\2022\70701660\" ' ?
Const dExtension As String = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Const dwbNameLeft As String = "Name_"
Const dwsNameLeft As String = "Upload_"
' Template
Const twbPath As String = "C:\Test\2022\70701660\" ' ?
Const twbName As String = "Template.xlsx" ' usually .xltx ?
Const twsName As String = "Sheet1"
Const tfCellAddress As String = "E7"
Const tnCellAddress As String = "B2"
Application.ScreenUpdating = False
Dim swb As Workbook: Set swb = Workbooks.Open(swbPath & swbName)
Dim sws As Worksheet: Set sws = swb.Worksheets(swsID)
Dim slCell As Range: Set slCell = sws.Columns(sCols) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Dim srCount As Long: srCount = slCell.Row - sfRow + 1
Dim dCount As Long: dCount = Int(srCount / sRows)
If srCount Mod sRows > 0 Then
dCount = dCount + 1
End If
Dim sfrrg As Range: Set sfrrg = sws.Rows(sfRow).Columns(sCols)
Dim cCount As Long: cCount = sfrrg.Columns.Count
Dim twbFilePath As String: twbFilePath = twbPath & twbName
Dim srg As Range
Dim twb As Workbook
Dim tws As Worksheet
Dim d As Long
Dim crCount As Long
For d = 1 To dCount
If srCount < sRows Then
crCount = srCount
Else
crCount = sRows
srCount = srCount - sRows
End If
Set srg = sfrrg.Resize(crCount)
Set sfrrg = sfrrg.Offset(crCount) ' next
Set twb = Workbooks.Open(twbFilePath)
Set tws = twb.Worksheets(twsName)
tws.Range(tfCellAddress).Resize(crCount, cCount).Value = srg.Value
tws.Range(tnCellAddress).Value = dwsNameLeft & CStr(d)
Application.DisplayAlerts = False ' overwrite without confirmation
twb.SaveAs dPath & dwbNameLeft & CStr(d) & dExtension, dFileFormat
Application.DisplayAlerts = True
twb.Close SaveChanges:=False
Next d
swb.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Done."
End Sub

VBA to pull values from a variable number of worksheets with similar names from multiple workbooks

I want to use VBA to create a summary sheet in this workbook (storage workbook) that I am currently working in to go through multiple reports (over 100) and pull certain values.
Each report contains 10+ sheets, but I am only interested in copying cells A4:A5 from the sheets titled Day1, Day2, Day3, etc.
I found success using the code below and creating a module for each Day 1, Day 2, Day 3, etc.
Sub Day1_values()
Dim basebook As Workbook
Dim mybook As Workbook
Dim ws As Worksheet
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range
Dim foldername As String
Dim getpath As String
Dim myFilePath As String
SaveDriveDir = CurDir
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If MyPath <> "" Then
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xlsm")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
rnum = 2
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
' This will add the workbook name in column A
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name
basebook.Worksheets(1).Cells(rnum, "B").Value = mybook.Path
Cnum = 3 'begin pasting the values in column 3
For Each cell In mybook.Worksheets("Day1").Range("A4:A5")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell
mybook.Close False
rnum = rnum + 1
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End If
End Sub
The problem is that each workbook contains a different number of days. For example report 1 has day1 - day5 and report 2 only has day1 - day2.
The above code doesn't work when I create a module for Day3 because it will see that report 2 does not have a Day3 and the code will break because subscript out of range.
Does anyone have any idea how I can manipulate the code in a way to say that for each workbook, if the sheet name contains Day* to copy cells A4:A5 and paste them in my storage workbook?
There was a similar post here: Loop through worksheets with a specific name and they successfully used this code for their problem:
If ws.Name Like "danger" & "*" Then
ws.Range("A1").Interior.ColorIndex = 37
End If
I just don't know how to add that into my existing code.
Try something like this:
Sub ImportWorksheetData()
Dim basebook As Workbook, mybook As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim rwResults As Range, nm As String, f
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If Len(MyPath) = 0 Then Exit Sub 'no folder chosen
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" 'ensure trailing \
Set basebook = ThisWorkbook
Set rwResults = basebook.Worksheets(1).Rows(2)
f = Dir(MyPath & "*.xlsm")
Do While Len(f) > 0
Set mybook = Workbooks.Open(MyPath & f)
For Each ws In mybook.Worksheets
'Does the worksheet name match our pattern?
nm = UCase(Replace(ws.Name, " ", "")) 'ignore spaces when checking
If nm Like "DAY#" Or nm Like "DAY##" Then '# = any digit
rwResults.Columns("A").Value = f
rwResults.Columns("B").Value = MyPath
rwResults.Columns("C").Value = ws.Name
rwResults.Columns("D").Value = ws.Range("A4").Value
rwResults.Columns("E").Value = ws.Range("A5").Value
Set rwResults = rwResults.Offset(1, 0) 'move down for next sheet
End If
Next ws
mybook.Close False 'no save
f = Dir()
Loop
End Sub
Collect Data from Workbooks
Option Explicit
Sub CollectData()
Const sPattern As String = "*.xlsm"
Const swsPatternLCase As String = "day*"
Const sAddressesList As String = "A4,A5" ' add more
Const dID As Variant = 1 ' or e.g. "Sheet1" - is safer
Const dFirst As String = "A2" ' Destination First Cell Address
Const dLower As Long = 3 ' first column to write the cell values to
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = dwb.Path & "\"
If .Show = -1 Then
sPath = .SelectedItems(1)
End If
End With
If sPath = "" Then Exit Sub ' dialog canceled
Dim sName As String: sName = Dir(sPath & "\" & sPattern)
If Len(sName) = 0 Then
MsgBox "No files in the Directory"
Exit Sub
End If
Dim sAddresses() As String: sAddresses = Split(sAddressesList, ",")
Dim aUpper As Long: aUpper = UBound(sAddresses)
Dim cCount As Long: cCount = dLower + aUpper
Application.ScreenUpdating = False
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim Dat As Variant: ReDim Dat(1 To cCount)
Dim swb As Workbook
Dim sws As Worksheet
Dim n As Long
Dim a As Long
' Write each worksheet's results to an array ('Dat') and add the array
' to the dictionary ('dict').
Do While sName <> ""
Set swb = Workbooks.Open(sPath & "\" & sName)
Dat(1) = swb.Name
Dat(2) = sPath ' or swb.Path - it's always the same '***
For Each sws In swb.Worksheets
If LCase(sws.Name) Like swsPatternLCase Then
'Dat(2) = sws.Name ' looks more useful '***
For a = 0 To aUpper
Dat(dLower + a) = sws.Range(sAddresses(a)).Value
Next a
n = n + 1
dict.Add n, Dat
End If
Next sws
swb.Close False
sName = Dir()
Loop
Dim rCount As Long: rCount = dict.Count
If rCount > 0 Then
' Write the results from the arrays in the dictionary
' to a 2D one-based array ('dData').
Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
Dim r As Long
Dim c As Long
For Each Dat In dict.Items
r = r + 1
For c = 1 To cCount
dData(r, c) = Dat(c)
Next c
Next Dat
With dwb.Worksheets(dID).Range(dFirst).Resize(, cCount)
' Write the results to the destination range (in one go).
.Resize(rCount).Value = dData
' Clear the contents below the destination range.
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
.EntireColumn.AutoFit
End With
dwb.Save
End If
Application.ScreenUpdating = True
MsgBox "Data collected.", vbInformation, "Collect Data"
End Sub

Resources