before people say this question has been asked before, trust me I have read most entries but I just can't get my head around it. I have a fold of about 550 CSV files, each about 25mb. I'm trying to automatically remove the unnecessary columns to bring the file size down to 2mb, so that then I can analyse them with another language ( that I'm more comfortable with )
I found this code on the net :
Option Explicit
Sub Delete_First_Last_Columns_From_CSV_Files()
Dim source_folder_name As String
source_folder_name = "C:\Users\Domenic\Desktop\" 'change the path to the source folder accordingly
If Right(source_folder_name, 1) <> "\" Then
source_folder_name = source_folder_name & "\"
End If
If Len(source_folder_name) = 0 Then
MsgBox "The path to the source folder is invalid!", vbExclamation, "Invalid Path"
Exit Sub
End If
Application.ScreenUpdating = False
Dim columns_to_delete As Variant
columns_to_delete = Array("First", "Last") 'change and/or add column headers as desired
Dim current_filename As String
current_filename = Dir(source_folder_name & "*.csv", vbNormal)
Dim file_count As Long
While Len(current_filename) > 0
file_count = file_count + 1
Delete_Columns_from_CSV_File source_folder_name & current_filename, columns_to_delete
current_filename = Dir
Wend
Application.ScreenUpdating = True
MsgBox "Number of files processed: " & file_count, vbInformation, "Files Processed"
End Sub
Private Sub Delete_Columns_from_CSV_File(ByVal source_filename As String, ByVal columns_to_delete As Variant)
Dim source_workbook As Workbook
Set source_workbook = Workbooks.Open(Filename:=source_filename)
Dim source_worksheet As Worksheet
Set source_worksheet = source_workbook.Worksheets(1)
Dim column_found As Range
Dim i As Long
For i = LBound(columns_to_delete) To UBound(columns_to_delete)
Set column_found = source_worksheet.Rows(1).Find(what:=columns_to_delete(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not column_found Is Nothing Then
column_found.EntireColumn.Delete
End If
Next i
source_workbook.Close SaveChanges:=True
End Sub
I paste this code through visual basic part of EXCEL to the current workbook, but it only runs the script on the current file and not the rest of the folder. How do I fix it so it runs on all files ?
Related
i got a variable:
V_WBNameOutPut as string
and use it inside the following code:
Application.Workbooks(V_WBNameOutPut).Activate
This two part of code are inside a huger code which work fine for 99.99% of different users, but only for one user the code go in error and when I debug its stop to Application.Workbooks(V_WBNameOutPut).Activate line.
And the error is the following:
Runtime Error 9: Subscript Out of Range
Any ideas why this happend and possible solution?
Thanks
I try it to debug but the code works fine but for one particular user it doesn't
The subroutine to generate the output file, which the Application.Workbooks(V_WBNameOutPut).Activate refers to:
Sub CreateWB()
Dim File_Name As Variant
Dim File_Name_Saved As String
Dim i_attempt As Integer
Dim NewWorkBook As Workbook
Set NewWorkBook = Workbooks.Add
Do While i_attempt < 2
i_attempt = i_attempt + 1
File_Name = Application.GetSaveAsFilename(InitialFileName:=V_WBNameOutPut, filefilter:="Excel Files(*.xlsx),*.xlsx,Excel-Macro Files (*.xlsm),*.xlsm", Title:="Please choose a Folder")
File_Name_Saved = Left(Right(File_Name, Len(V_WBNameOutPut) + 5), Len(V_WBNameOutPut))
If File_Name = False Then
ActiveWorkbook.Close
End
Else
If UCase(File_Name_Saved) <> UCase(V_WBNameOutPut) Then
If i_attempt < 2 Then
MsgBox "Please do not change the File name" & vbCrLf & i_attempt & "/2 Attempt"
Else
ActiveWorkbook.Close
End
End If
Else
Application.DisplayAlerts = False
NewWorkBook.SaveAs File_Name, ConflictResolution:=True
Exit Do
End If
End If
Loop
End Sub
You can loop through the open workbooks looking for a match without the file extension. A better solution would be to make CreateWB a function that returns the saved filename.
Option Explicit
Dim V_WBNameOutPut
Sub test()
Dim wb As Workbook
V_WBNameOutPut = "test2"
CreateWB
For Each wb In Workbooks
If wb.Name Like V_WBNameOutPut & "*" Then
wb.Activate
Exit For
End If
Next
Sheets(1).Cells(1, 1).Select ' active workbook
End Sub
Sub CreateWB()
Dim NewWorkBook As Workbook
Dim fso As Object, bSaveOK As Boolean, i_attempt As Integer
Dim File_Name As Variant, File_Name_Saved As String
Set fso = CreateObject("Scripting.FileSystemObject")
For i_attempt = 1 To 2
File_Name = Application.GetSaveAsFilename( _
InitialFileName:=V_WBNameOutPut, _
filefilter:="Excel Files(*.xlsx),*.xlsx,Excel-Macro Files (*.xlsm),*.xlsm", _
Title:="Please choose a Folder")
If File_Name = False Then Exit Sub
bSaveOK = (fso.getbasename(File_Name) = V_WBNameOutPut)
If Not bSaveOK And i_attempt = 1 Then
MsgBox "Please do not change the File name from " & V_WBNameOutPut _
& vbCrLf & i_attempt & "/2 Attempt"
Else
Exit For
End If
Next
' create workbook and save
If bSaveOK Then
Set NewWorkBook = Workbooks.Add
Application.DisplayAlerts = False
NewWorkBook.SaveAs File_Name, ConflictResolution:=True
Application.DisplayAlerts = True
End If
End Sub
I am very new to Vba and coding in general, so please excuse any mistake I may have made. I keep getting a run time error "subscript out of range". This code is meant to work in conjunction with the first module that I wrote, which works fine, but I need to verify that this works first before I integrate it. This code is meant to find what is referred to as an "h-number", then match that h number to a list generated by the first module, then it will copy certain dates corresponding to the h number back to the current workbook (I have a place holder code for the time being). My Code:
Sub filematcher()
Dim Activesource As Workbook 'saves file so that it can be refrenced in code
Dim AOI2 As Range
Call OptimizeCode_Begin
'opens the file
Set Activesource = Workbooks.Open(Filename:="C:\Users\ebecerra\Desktop\active status sheet
copy for macro.xlsx", ReadOnly:=True)
Set AOI2 = Activesource.Sheets("Sheet 1").Range("A")
For Each cell In AOI2
On Error Resume Next
H_source = cell.Value
'matches the H number found to the one on the master sheet
With ThisWorkbook.Sheets("Collated Data").Range("A")
Set H_match = .Find(H_source, LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
On Error Resume Next
End With
'find the row number that coresponds to the found h-number
Y_Match = H_match.Row
'records the found h number to verify that code works
ThisWorkbook.Sheets("Collated Data").Cells(Y_Match, H).Value = H_source
Next cell
Activesource.Close savechanges:=False
On Error GoTo ErrorHandle_2
ErrorHandle_2:
Set Activesource = Nothing
'End optimizer
Call OptimizeCode_End
End Sub
IF it matters this is the code optimizer as well as the first module that I mentioned:
Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean
Sub OptimizeCode_Begin()
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub
Sub collectdata()
Dim MyFSO As New FileSystemObject 'declaring and initializing FSO (file system object)
Dim wkbsource As Workbook 'workbook variable to store the raw excel file
Dim iRow As Long ' to store the last blank row available in collected data sheet before pasting the raw data
Dim iTotalRow As Long 'to store the last non-blank row availbe in collected data sheet after pasting the raw data
Dim sPath As String ' to store the selected folder path
Dim SourceFolder As Folder 'to store folder path
Dim MyFile As File 'File variable for FSO
Dim Filename As String ' to store the excel file name for column A in collected data sheet
Dim iTotalFiles As Long 'to store the count of all excel files available in selected folder
Dim DialogBox As FileDialog 'file dialog to select the folder name
Dim Hours As Range 'To store the Hours of test ran
Dim IRtestdate As Range 'To store the date of the IR reading
Dim iFailsRow As Long 'to identify the last cell used, therefore identifies how many pcs ran
Dim Count As Long 'To store the amount of bad pcs
Dim AOI As Range 'To determine the area for which the program will look for bad pcs
'Begin Optimizer
Call OptimizeCode_Begin
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker) 'Assiging Folder picker dialog box
With DialogBox
.Title = "Select Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then Exit Sub 'no folder selected
sPath = .SelectedItems(1)
End With
'Check wheather selected folder exists or not
If Not MyFSO.FolderExists(sPath) Then
MsgBox "folder is not available.", vbOKOnly + vbCritical, "Error"
appication.ScreenUpdating = True
Exit Sub
End If
Set SourceFolder = MyFSO.GetFolder(sPath)
'Get the count of all excel files available in Sourcefolder (selected folder)
iTotalFiles = 0
For Each MyFile In SourceFolder.Files
If MyFSO.GetExtensionName(MyFile) = "xls" Then
iTotalFiles = iTotalFiles + 1
End If
Next MyFile
'Code to terminate the code if there is no Excel file availbe in Selected folder
If iTotalFiles = 0 Then
MsgBox "no Excelfile available.", vbOKOnly + vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
'Code to compile the data from Raw file to collecter
For Each MyFile In SourceFolder.Files
If MyFSO.GetExtensionName(MyFile) = "xls" Then
'Code to identify the last Blank row number in collated data sheet
iRow = ThisWorkbook.Sheets("Collated data").Range("B" & Rows.Count).End(xlUp).Row + 1
'Store the file name
Filename = MyFSO.GetFileName(MyFile)
'Code to open the raw file
Set wkbsource = Workbooks.Open(Filename:=MyFile, ReadOnly:=True)
On Error GoTo Nextloop
'finds out if the file belongs to Jeff, if not it skips the file
Set requester = wkbsource.ActiveSheet.Range("F3")
If requester.Value = "Jeff Horn" Then
GoTo Valid
Else
GoTo Nextloop
End If
Valid:
'code to identify If the Sheet is Blank
If IsEmpty(wkbsource.Sheets("Uncorrected").Range("N23").Value) = True Then GoTo Nextloop
'finds Group number and pastes to collated sheet
ThisWorkbook.Sheets("Collated Data").Range("B" & iRow) = wkbsource.Sheets("Uncorrected").Range("F2")
'finds Test ran and pastes to collated sheet
ThisWorkbook.Sheets("Collated Data").Range("C" & iRow) = wkbsource.Sheets("Uncorrected").Range("B1")
'Code to read the hours ran, find the highest value, and display it in the Collated data sheet
With wkbsource.Sheets("Uncorrected").Range("M21:T21")
Set Hours = .Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious)
End With
If Hours Is Nothing Then
GoTo Testdate
Else: On Error GoTo Testdate
End If
ThisWorkbook.Sheets("Collated Data").Range("D" & iRow) = Hours
Testdate:
'Finds the the IRtestdate and Pastes that value into the Collated data sheet
With wkbsource.Sheets("Uncorrected").Range("M18:T18")
Set IRtestdate = .Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious)
End With
If IRtestdate Is Nothing Then
GoTo FailsCounter
Else: On Error GoTo FailsCounter
End If
ThisWorkbook.Sheets("Collated Data").Range("E" & iRow) = IRtestdate
FailsCounter:
'code to identify the column that needs to be counted dynamically based on Hours tested
iFailsRow = wkbsource.Sheets("Uncorrected").Range("N" & Rows.Count).End(xlUp).Row
Y = Hours.Row + 2
X = Hours.Column
Count = 0
Set AOI = wkbsource.Sheets("Uncorrected").Range(Cells(Y, X), Cells(iFailsRow, X))
'Code to count the number of fails in each file
For Each cell In AOI
If cell.Value <= 0.001 Then
Count = Count + 1
On Error Resume Next
End If
Next
Total_Parts = iFailsRow - 22
ThisWorkbook.Sheets("Collated Data").Range("F" & iRow) = Count & " of " & Total_Parts
'Code to identify the last non-blank row in collated data sheet after pasting raw data
iTotalRow = ThisWorkbook.Sheets("Collated data").Range("B" & Rows.Count).End(xlUp).Row
'Code to update the file name
ThisWorkbook.Sheets("Collated Data").Range("A" & iRow & ":A" & iTotalRow).Value = Filename
Application.CutCopyMode = False
Nextloop:
wkbsource.Close savechanges:=False
On Error GoTo ErrorHandle
ErrorHandle:
Set wkbsource = Nothing
End If
Next MyFile
MsgBox "Data collated", vbOKOnly + vbInformation, "Done!"
'End optimizer
Call OptimizeCode_End
End Sub
So I want to automate a lot of manual work of copy/paste with the help of a Macro. The macro should read all files from folder one by one, copy the content from that source file range "I9:J172" and paste it on the destination file (where the macro is of course) on the column first blank row.
Application.ScreenUpdating = False
'For Each Item In franquicia
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open("C:\folder\inventory.xlsb", True, True)
' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("INV").Range("I9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Rows.Count
' FIND FIRST BLANK CELL
Dim LastRow As Long
LastRow = Worksheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
Dim iCnt As Integer ' COUNTER.
For iCnt = 1 To iTotalRows
Worksheets("Hoja1").Range("A" & LastRow & ":B" & iCnt).Value = src.Worksheets("INV").Range("I9:J172" & iCnt).Value
Next iCnt
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
'Next Item
I want to solve first this last row problem and then do an array and the loop to read all the files one by one.
Thank you!
The following code does what you've described, and the animated gif demonstrates with 3 test files (with test data in the columns you mentioned). The first part of the gif shows the contents of 2 of the test files, and then runs the macro, stepping through it, showing the result on a "combined" sheet. Click on the gif to see better detail. Note that each test file's data must be on a "data" sheet. You can modify, of course.
Option Explicit
Dim theDir As String, alreadyThere As Boolean, wk As Workbook
Dim sh As Worksheet, comboSh As Worksheet, comboR As Range
Dim r As Range, s As String, numFiles As Integer
Const ext = ".xlsx"
Sub CombineFiles()
Set comboSh = getSheet(ThisWorkbook, "Combined", True)
theDir = ThisWorkbook.Path
s = Dir(theDir & "\*" & ext)
Set comboR = comboSh.Range("A1")
While s <> ""
ThisWorkbook.Activate
If comboR <> "" Then Set comboR = comboR.Offset(0, 2)
comboR.Activate
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = getSheet(wk, "data", False)
Set r = sh.Range("I9:J72")
'Set r = sh.Range(r, r.End(xlToRight))
'Set r = sh.Range(r, r.End(xlDown))
r.Copy
comboSh.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
numFiles = numFiles + 1
Wend
MsgBox ("done")
End Sub
Function getSheet(wk As Workbook, shName As String, makeIfAbsent As Boolean) As Worksheet
alreadyThere = False
For Each sh In wk.Worksheets
If sh.Name = shName Then
alreadyThere = True
Set getSheet = sh
End If
Next
If Not alreadyThere Then
If makeIfAbsent Then
Set getSheet = wk.Sheets.Add
getSheet.Name = shName
Else
MsgBox shName & " sheet not found -- ending"
End
End If
End If
End Function
I may be arriving to the party too late. It seems like you got the solution you were after. For future reference, try the AddIn below. This will do all kinds of copy/paste/merge tasks.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
I have searched other questions but cant find what I need.
I have a folder with lost of sub folder, lots of sub folders in them and so on until I get to a list of hundreds of documents in them.
I need a macro in Excel to list the documents in every sub folder of a given directory and also hyperlink to the document.
I have found a macro that will list the documents and create a hyperlink to them in 1 directory but does not delve into the sub directories.
I'm hoping someone can help.
Thanks.
Tom
The macro I am using is:
Option Compare Text
Option Explicit
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0
End Function
Sub HyperlinkFileList()
'Macro purpose: To create a hyperlinked list of all files in a user
'specified directory, including file size and date last modified
'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added
'in Excel 2000. This code tests the Excel version and does not use the
'Texttodisplay property if using XL 97.
Dim fso As Object, _
ShellApp As Object, _
file As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer
'Turn off screen flashing
Application.ScreenUpdating = False
'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Please choose a folder", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.Path
Set SubFolder = fso.GetFolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each file In SubFolder
If Not Excludes(Right(file.Path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=file.Path, _
TextToDisplay:=file.Name
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = file.datelastModified
End With
End With
End If
Next
End Sub
CURRENT UPDATE:
'Global Declaration for Start Row
Public lngRow As Long
Sub pReadAllFilesInDirectory()
Dim strFolderPath As String
Dim BlnInclude_subfolder As Boolean
'Set Path here
strFolderPath = "C:\Users\Thomas\Documents\test file"
'set start row
lngRow = 1
'Set this true if you want list of sub-folders as well
BlnInclude_subfolder = True
'---------- Reading of files in folders and sub-folders------
Call ListMyFiles(strFolderPath, BlnInclude_subfolder)
'---------- Reading of files in folders and sub-folders------
End Sub
Sub ListMyFiles(mySourcePath As String, blnIncludeSubfolders As Boolean)
Dim MyObject As Object
Dim mySource As Object
Dim mySubFolder As Object
Dim myfile As Object
Dim iCol As Long
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set mySource = MyObject.GetFolder(mySourcePath)
'Loop in each file in Folder
For Each myfile In mySource.Files
iCol = 1
Sheet1.Cells(lngRow, iCol).Value = myfile.Name 'File Name
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
myfile.Path, TextToDisplay:=myfile.Name
iCol = iCol + 1
Sheet1.Cells(lngRow, iCol).Value = myfile.Path 'File Path/Location
lngRow = lngRow + 1
Next
If blnIncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True)
Next
End If
THE PROBLEM WITH THE ABOVE IS THE HYPERLINK
I WANT THE HYPERLINK TO BE IN THE SAME CELL THAT THE NAME OF THE FILE IS IN HOWEVER THE HYPERLINK ENDS UP IN WHAT EVER CELL WAS ACTIVE BEFORE I RAN THE MACRO AND IS THE NAME AND LINK TO THE FINAL FILE FOUND
I just did that yesterday, except for the hyperlink thing.
Sub startIt()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\whatever"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim File
For Each File In Folder.Files
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _
File.Path, TextToDisplay:=File.Name
i = i + 1
Next
End Sub
*Edit, was overwriting some cells
Try this one. this is part of one of my mail macro where it digs into the folders and subfolders and list all the files on the sheet1. See if you can adjust this as per your need.
Sub foldersubFiles()
Dim fs$, f
Sheets("Sheet 1").Activate
fs = "C:\Users\" ' path of your main folder
f = Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & _
fs & """ /b/s").StdOut.ReadAll, vbCrLf) 'look in all sub folders
[a:a].ClearContents
[a1].Resize(UBound(f)).Value = Application.WorksheetFunction.Transpose(f)
End Sub
I'm trying to write code that on Commandbutton2_Click searches through the folder that the file is in, takes a value from the same cell in each file and adds these together.
I have this:
Private Sub CommandButton2_Click()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim strFolderPath As String
Dim strToolNumber As String
Dim RingCount As Integer
RingCount = 0
strToolNumber = CStr(Sheets("Sheet1").Range("B9").Value)
strFolderPath = "T:\Engineering\Tooling\Tooling Control Engineering\Press Tool Inspection Records\" & strToolNumber & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = strFolderPath
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(FileName:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
RingCount = Val(RingCount) + ActiveWorkbook.Sheets("Sheet1").Range("F11").Value
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
ActiveSheet.Unprotect Password:=""
ActiveWorkbook.Sheets("Sheet1").Range("F13").Value = (RingCount + ActiveWorkbook.Sheets("Sheet1").Range("F11").Value)
ActiveSheet.Protect Password:=""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
whose main body was pieced together from different google searches - but it continually returns a value of 0 (despite the cells in the other sheets having values).
I read somewhere that Application.Filesearch does not work for versions of Excel later than 2003, could this be the source of the problem?
Its possible to pull that value youre interested in without opening each workbook. Its much more efficient and reliable.
This code iterates through all files in the path variable and pulls values without opening the Excel files. It then prints the values starting at F20. You can then make another wrapper function to sum them up and delete or whatever you want. Hope this helps
Private Sub CommandButton2_Click()
Dim tool As String
tool = CStr(Sheets("Sheet1").range("B9").Value)
Dim path As String
path = "T:\Engineering\Tooling\Tooling Control Engineering\Press Tool Inspection Records\" & strToolNumber & "\"
Dim fname
fname = Dir(CStr(path)) ' gets the filename of each file in each folder
Do While fname <> ""
If fname <> ThisWorkbook.Name Then
PullValue path, fname ' add values
End If
fname = Dir ' get next filename
Loop
End Sub
Private Sub PullValue(path As String, ByVal fname As String)
With range("F" & (range("F" & Rows.Count).End(xlUp).Row + 1))
.Formula = "='" & path & "[" & fname & "]Sheet1'!F11"
.Value = .Value
End With
End Sub