I have the following code, but am looking to change it so the output only provides the first part of the file name. The file names are in the following format. ZipCode_Name_Date. I only want the part of the name which states the Zipcode to print out.
Option Explicit
Sub GetFileDetails()
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objFile As Scripting.File
Dim nextRow As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("")
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each objFile In objFolder.Files
Cells(nextRow, 1) = objFile.Name
nextRow = nextRow + 1
Next
End Sub
Please, replace Cells(nextRow, 1) = objFile.Name with Cells(nextRow, 1) = Split(objFile.Name, "_")(0).
Extract FileParts
If you write it as a function...
Option Explicit
Function GetFirstFileNamePart( _
ByVal FolderPath As String, _
ByVal FilePartsDelimiter As String) _
As Variant
Dim fsoFolder As Object
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(FolderPath) Then Exit Function
Set fsoFolder = .GetFolder(FolderPath)
End With
Dim fCount As Long: fCount = fsoFolder.Files.Count
If fCount = 0 Then Exit Function
Dim Data As Variant: ReDim Data(1 To fCount, 1 To 1)
Dim fsoFile As Object
Dim n As Long
For Each fsoFile In fsoFolder.Files
n = n + 1
' This is the place to modify what to return.
' 0 means the part before the first found delimiter.
Data(n, 1) = Split(fsoFile.Name, FilePartsDelimiter)(0)
Next fsoFile
GetFirstFileNamePart = Data
End Function
... you can easily utilize it in the calling procedure (adjust the constants):
Sub GetFirstFileNamePartTEST()
' Constants
Const FilePartsDelimiter As String = "_"
Dim FolderPath As String
FolderPath = Environ("OneDrive") & "\Documents\"
Const dCol As String = "A"
' Using the function, write the data to a 2D one-based one-column array.
Dim Data As Variant
Data = GetFirstFileNamePart(FolderPath, FilePartsDelimiter)
' Validate.
If IsEmpty(Data) Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
' Write the data to the range.
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
Dim dCell As Range
Set dCell = ws.Cells(ws.Rows.Count, dCol).End(xlUp).Offset(1)
Dim drg As Range: Set drg = dCell.Resize(UBound(Data, 1), UBound(Data, 2))
drg.Value = Data
MsgBox "First filename parts copied.", vbInformation
End Sub
Related
I am struggling to fix the issue but its something beyond my knowledge.
I want to extract more columns data by adding "Header Name" in the code. But my code works only for single header.
I tried to add an array like this
Const sHeader As String = Array("Category", "Names") and so on.
but I get an error.
I want to Add File Names to loop through them in the folder and skip rest of the files.
Like this Const sFileName As String = Array("File1", "File2") and so on.
i want to copy and paste each Column through its Header Separat.
I would appreciate if anyone could help me with this.
Sub ImportColumns()
' Source
Const sFilePattern As String = "*.xlsx"
Const sExceptionsList As String = "Sheet1" ' comma-separated, no spaces
Const sHeader As String = "Category"
Const sHeaderRow As Long = 1
' Destination
Const dColumn As String = "A"
' Source
Dim sfd As FileDialog
Set sfd = Application.FileDialog(msoFileDialogFolderPicker)
'sfd.InitialFileName = "C:\Test\"
Dim sFolderPath As String
If sfd.Show Then
sFolderPath = sfd.SelectedItems(1) & Application.PathSeparator
Else
'MsgBox "You canceled.", vbExclamation
Beep
Exit Sub
End If
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
'MsgBox "No files found.", vbExclamation
Beep
Exit Sub
End If
Dim sExceptions() As String: sExceptions = Split(sExceptionsList, ",")
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.ActiveSheet ' improve!
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
' Loop.
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim shrg As Range
Dim sData() As Variant
Dim sfCell As Range
Dim slCell As Range
Dim srCount As Long
Dim wsCount As Long
Do While Len(sFileName) > 0
Set swb = Workbooks.Open(sFolderPath & sFileName)
For Each sws In swb.Worksheets
If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
Set shrg = sws.Rows(sHeaderRow)
Set sfCell = shrg.Find(sHeader, shrg.Cells(shrg.Cells.Count), _
xlFormulas, xlWhole)
If Not sfCell Is Nothing Then
Set sfCell = sfCell.Offset(1)
Set slCell = sfCell _
.Resize(sws.Rows.Count - sHeaderRow) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not slCell Is Nothing Then
srCount = slCell.Row - sHeaderRow
Set srg = sfCell.Resize(srCount)
End If
End If
If srCount > 0 Then
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
dfCell.Resize(srCount).Value = sData
Set dfCell = dfCell.Offset(srCount)
wsCount = wsCount + 1
srCount = 0
End If
End If
Next sws
swb.Close SaveChanges:=False
sFileName = Dir
Loop
' Save the destination workbook.
'dwb.Save
Application.ScreenUpdating = True
MsgBox wsCount & " '" & sHeader & "' columns copied.", vbInformation
End Sub
In my opinion, "Do While" loops are quite slow, I would try to avoid them. Instead, use defined "For" or "For each" loops.
The key is to use Arrays, and in every "For" loop ask for the information stored in these arrays.
Here is an idea (it is not finished) using "For" loops, one inside other one. The first is to Open Files, second to Open Sheets and the third to check the Headers. Please check the variables "arrFiles(X)" und "arrHeaders(Y)"
Dim wbkSheet As Worksheet
Dim Wbk As Workbook
Dim X As Double, Y As Double
Dim sHeaderRow As Byte: sHeaderRow = 1
Dim shRg As Range, sfCell As Range
'Here we set the values for the Files names and Table Headers names. They'll be Arrays
Dim arrFiles As Variant: arrFiles = Array("File_1.xlsx", "Files_2.xlsx")
Dim arrHeader As Variant: arrHeader = Array("Category", "Names")
'Loop to check every file that is in the Array
For X = LBound(arrFiles, 1) To UBound(arrFiles, 1)
'Loop to open every file of the list
'Example:
Set Wbk = Workbooks.Open(sFolderPath & arrFiles(X))
'...
For Each wbkSheet In Wbk.Worksheets
'Loop to open every sheet of the openned file.
For Y = LBound(arrHeader, 1) To UBound(arrHeader, 1)
'Loop to check every column of the sheet
'Example:
Set shRg = wbkSheet.Rows(sHeaderRow)
Set sfCell = shRg.Find(arrHeader(Y), shRg.Cells(shRg.Cells.Count), xlFormulas, xlWhole)
'...
Next Y
Next wbkSheet
Next X
With this code, you might be able to add as many files and headers you want.
Now, in my opinion the best solution will be to use ADO Excel, it is way faster (it uses SQL queries) and you don't need to open the files. The loops will be much shorter because you just stablish SQL Queries.
One suggestion to initialize your array using a Const would be to declare the headers this way:
Const ALL_HEADERS As String = "Category,Names"
Then later, when you set up your array it will be:
Dim sHeader() As String
sHeader = Split(ALL_HEADERS, ",")
And your array is set.
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
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
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
The below code works until used on a directory with paths over 255 characters.
Runtime error 13 mismatch occurs.
I have a hunch that the built in .transpose operation does not support 255 characters.
How can I manually do this operation?
My other crawler is not recursive, so I have never had this issue.
At this point I'm wondering if recursive efficiency is worth it.
Also the UNC path output is a requirement, shortening it to drive letter is a not an option.
Option Explicit
Sub CreateFileStructureReport()
Dim Msheet As String
Dim minNum As Integer
Msheet = Application.ActiveWorkbook.Path
Application.Calculation = xlCalculationManual
Call GetFileList
Application.Calculation = xlCalculationAutomatic
Range("A2").Select
End Sub
Sub GetFileList()
Dim ans As String
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
ans = Application.CommandBars("Web").Controls("Address:").Text
If ans = "" Then Exit Sub
ans = Left(ans, InStrRev(ans, "\"))
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ans)
'the variable dimension has to be the second one
ReDim myResults(0 To 6, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Extension"
myResults(1, 0) = "Bytes"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified Info"
myResults(4, 0) = "Last Accessed"
myResults(5, 0) = "File Name"
myResults(6, 0) = "\\Root\T01\T02\T03\T04\T05\T06\T07\T08\T09\T10\T11\T12\T13\T14\T15\T16\T17\T18\T19\T20"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
DumpToWorksheet myResults
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
'load the array with all the files
For Each objFile In objFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 6, 0 To lCount)
myResults(0, lCount) = objFile.Type
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Name
myResults(6, lCount) = objFile.Path
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
DoEvents
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub DumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub