I have a folder D:\Arun\myfolder. Inside this say I have 60 files. I want to know the number of rows inside each file like below: (probably written in a separate sheet)
File1 - 240 rows
File2 - 321 rows
File3 - 178 rows
..
..
So I'm trying with the below code, but it is not giving me any output. I have very little knowledge in VBA and I'm not sure why the below code is not working.
Sub CountRows()
Dim wb As Workbook, wbXLS As Workbook
Dim sPath As String, sFilename As String
Dim NbRows As Integer, rg As Range
DisplayAlerts = False
Set wb = ThisWorkbook
Application.ScreenUpdating = False
sPath = "D:\Arun\myfolder" 'Path of XLS Files
sFilename = Dir(sPath & "*.xls")
On Error Resume Next
Do While Len(sFilename) > 0
If sFilename <> ThisWorkbook.FullName Then
Set wbXLS = Workbooks.Open(sPath & sFilename) 'open file
NbRows = wbXLS.Sheets(1).Range("A60000").End(xlUp).Row 'nb of rows
Set rg = wb.Worksheets("Check").Range("A60000").End(xlUp).Offset(1, 0)
rg = sFilename
rg.Offset(0, 1) = NbRows
wbXLS.Close False 'close file
End If
sFilename = Dir
Loop
Application.ScreenUpdating = True
DisplayAlerts = True
End Sub
VBA has methods that make looping through files much easier. Try looping all the .xls files in your folder like this
Sub count_rows()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb, wbXLS As Workbook
Set wb = ActiveWorkbook 'the workbook where you output the data must be active when you run the macro
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim myfolder As Object
Set myfolder = objFSO.GetFolder("INSERT YOUR FOLDER PATH HERE") 'sets the folder where you have the .xls files to loop
For Each objFil In myfolder.Files
i = i + 1
If InStr(1, objFil.name, ".xls") > 0 Then 'you make sure you are only working with .xls files inside your folder
Set wbXLS = Workbooks.Open(objFil.Path)
NbRows = wbXLS.Sheets(1).Range("A" & Cells(Rows.Count, 1).End(xlUp).Row).Row 'this will count all the cells in column A (it doesn't discriminate blank cells)
wb.Sheets(1).Cells(i, 1).Value = Replace(objFil.name, ".xls", "")
wb.Sheets(1).Cells(i, 2).Value = NbRows
wbXLS.Close False
Set wbXLS = Nothing
End If
Next objFil
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Related
Loop in folder is work, but don't work loop cells, don't work copy and paste selected data from 50 Excel workbooks to a single destination Excel workbook. I work in Windows Operating System. I have folder with 50 Excel files. I have single destiny Excel file. Data go from folder to 1 single Excel file.
Help, please.
Sub Combine()
Dim s As String, MyFiles As String
Dim endd As Integer, startt As Integer
Dim NewWb As Workbook
Dim newS As Worksheet
Dim i As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
With NewWb
Set newS = NewWb.Worksheets("Лист1")
End With
endd = i * 10 + 1
startt = endd - 10
MyFiles = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
s = Dir(MyFiles & "*.xlsx")
Do While s <> ""
[a1] = 0
If Dir = "" Then Exit Sub Else i = 1
Do
If Dir = "" Then Exit Do Else i = i + 1
Loop Until False
[a1] = i
With Workbooks.Open(MyFiles & s)
.Worksheets("Данные").Range("A1:C10").Copy
.Close SaveChanges:=False
End With
newS.Select
With newS
.Range("B" & startt & ":D" & endd).Paste
End With
s = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Combine()
Const FOLDER = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
Dim wb As Workbook, wbNew As Workbook, wsNew As Worksheet
Dim filename As String, i As Long, n As Integer, rng As Range
Set wbNew = Workbooks.Add(xlWBATWorksheet) '1 sheet
Set wsNew = wbNew.Sheets(1)
Application.ScreenUpdating = False
i = 1
filename = Dir(FOLDER & "*.xlsx")
Do While filename <> ""
' open book and copy range
Set wb = Workbooks.Open(FOLDER & filename, False, True) ' no link update, read only
Set rng = wb.Sheets(1).Range("A1:C10")
rng.Copy wsNew.Range("B" & i)
i = i + rng.Rows.Count
' close book goto next
wb.Close False
n = n + 1
filename = Dir
Loop
' save combined
wbNew.SaveAs ThisWorkbook.Path & "\Combined.xlsx"
wbNew.Close False
Application.ScreenUpdating = True
MsgBox n & " files copied", vbInformation
End Sub
I have a folder containing about 500-600 excel files from a script I have made where the file names end up like this
101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx
The file names follow that patern, 101a, 102a etc. What i want to do is merge those based on that paternt into 1 excel file. Therefore, the 101a12345.xlsx and 101a67899.xlsx should merge into an 101aMaster.xlsx. All excel files are single sheet.
I have found a sample code here which i am trying to implement: How to merge multiple workbooks into one based on workbooks names
Taken from the link above:
Sub test(sourceFolder As String, destinationFolder As String)
Const TO_DELETE_SHEET_NAME As String = "toBeDeleted"
'------------------------------------------------------------------
Dim settingSheetsNumber As Integer
Dim settingDisplayAlerts As Boolean
Dim dict As Object
Dim wkbSource As Excel.Workbook
Dim wks As Excel.Worksheet
Dim filepath As String
Dim code As String * 4
Dim wkbDestination As Excel.Workbook
Dim varKey As Variant
'------------------------------------------------------------------
'Change [SheetsInNewWorkbook] setting of Excel.Application object to
'create new workbooks with a single sheet only.
With Excel.Application
settingDisplayAlerts = .DisplayAlerts
settingSheetsNumber = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.DisplayAlerts = False
End With
Set dict = VBA.CreateObject("Scripting.Dictionary")
filepath = Dir(sourceFolder)
'Loop through each Excel file in folder
Do While filepath <> ""
If VBA.Right$(filepath, 5) = ".xlsx" Then
Set wkbSource = Excel.Workbooks.Open(sourceFolder & filepath)
Set wks = wkbSource.Worksheets(1)
code = VBA.Left$(wkbSource.Name, 4)
'If this code doesn't exist in the dictionary yet, add it.
If Not dict.exists(code) Then
Set wkbDestination = Excel.Workbooks.Add
wkbDestination.Worksheets(1).Name = TO_DELETE_SHEET_NAME
Call dict.Add(code, wkbDestination)
Else
Set wkbDestination = dict.Item(code)
End If
Call wks.Copy(Before:=wkbDestination.Worksheets(1))
wkbDestination.Worksheets(1).Name = VBA.Mid$(filepath, 6)
Call wkbSource.Close(False)
End If
filepath = Dir
Loop
'Save newly created files.
For Each varKey In dict.keys
Set wkbDestination = dict.Item(varKey)
'Remove empty sheet.
Set wks = Nothing
On Error Resume Next
Set wks = wkbDestination.Worksheets(TO_DELETE_SHEET_NAME)
On Error GoTo 0
If Not wks Is Nothing Then wks.Delete
Call wkbDestination.SaveAs(Filename:=destinationFolder & varKey & ".xlsx")
Next varKey
'Restore Excel.Application settings.
With Excel.Application
.DisplayAlerts = settingDisplayAlerts
.SheetsInNewWorkbook = settingSheetsNumber
End With
End Sub
However, this code opens all workbooks and at about 60-70 open excel files i receive an error: Run-time Error '1004' - Method 'Open' of object 'Workbooks' failed.
is there a way to make this code work?
Excel version is pro plus 2016.
Merge Workbooks
It will open the first of each files starting with the unique first four characters, and copy the first worksheet of each next opened file to the first opened file and finally save it as a new file.
There need not be only 2 files (starting with the same four characters) and there can only be one.
Adjust the values in the constants section.
Option Explicit
Sub mergeWorkbooks()
Const sPath As String = "F:\Test\2021\67077087\"
Const sPattern As String = "*.xlsx"
Const dPath As String = "F:\Test\2021\67077087\Destination\"
Const dName As String = "Master.xlsx"
Const KeyLen As Long = 4
Dim PatLen As Long: PatLen = Len(sPattern)
Dim fName As String: fName = Dir(sPath & sPattern)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do While Len(fName) > 0
dict(Left(fName, KeyLen)) = Empty
fName = Dir
Loop
Application.ScreenUpdating = False
On Error Resume Next
MkDir dPath
On Error GoTo 0
Dim wb As Workbook
Dim Key As Variant
Dim wsLen As Long
For Each Key In dict.Keys
Set wb = Nothing
fName = Dir(sPath & Key & sPattern)
Do While Len(fName) > 0
wsLen = Len(fName) - PatLen - KeyLen + 2
If wb Is Nothing Then
Set wb = Workbooks.Open(sPath & fName)
wb.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
'Debug.Print wb.Name
Else
With Workbooks.Open(sPath & fName)
'Debug.Print .Name
.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
.Worksheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
.Close False
End With
End If
fName = Dir
Loop
Application.DisplayAlerts = False
wb.SaveAs dPath & Key & dName ', xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Close False
Next Key
Application.ScreenUpdating = True
End Sub
Test for Names
Use the following to print all names in the active workbook to the VBE Immediate window (CTRL+G).
Sub listNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
Debug.Print nm.Name
Next nm
End Sub
First, check if the names (if any) are used in some formulas.
Use the following to delete all names in the active workbook.
Sub deleteNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
End Sub
Untested but here's one approach where you don't have multiple files open at the same time:
Sub test(sourceFolder As String, destinationFolder As String)
Dim dict As Object, code As String
Dim colFiles As Collection, f, k, wbNew As Workbook, wb As Workbook
Set dict = VBA.CreateObject("Scripting.Dictionary")
'ensure trailing "\"
EnsureSlash sourceFolder
EnsureSlash destinationFolder
'get a collection of all xlsx files in the source folder
Set colFiles = allFiles(sourceFolder, "*.xlsx")
If colFiles.Count = 0 Then Exit Sub 'no files
'organize the files into groups according to first four characters of the filename
For Each f In colFiles
code = Left(f.Name, 4)
If Not dict.exists(code) Then Set dict(code) = New Collection 'need new group?
dict(code).Add f 'add the file to the collection for this code
Next f
'loop over the groups
For Each k In dict
Set colFiles = dict(k) 'the files for this code
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet) 'one sheet
For Each f In colFiles
With Workbooks.Open(f.Path)
.Worksheets(1).Copy after:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = Replace(f.Name, ".xlsx", "")
.Close False
End With
Next f
Application.DisplayAlerts = False
wbNew.Sheets(1).Delete 'remove the empty sheet
Application.DisplayAlerts = True
wbNew.SaveAs destinationFolder & k & ".xlsx"
wbNew.Close
Next k
End Sub
'Return all files in `sourceFolder` which match `pattern`
' as a collection of file objects
Function allFiles(sourceFolder As String, pattern As String) As Collection
Dim col As New Collection, f
For Each f In CreateObject("scripting.filesystemobject").getfolder(sourceFolder).Files
If f.Name Like pattern Then col.Add f
Next f
Set allFiles = col
End Function
'Utility - check a path ends in a backslash
' use Application.PathSeparator if needs to be cross-platform
Sub EnsureSlash(ByRef f As String)
If Right(f, 1) <> "\" Then f = f & "\"
End Sub
I want to do the following:
Prompt user to choose a folder
Loop through folder (and subfolders if they exist)
Get all .xlsx files
Get specific column from those files (all have the same structure) and combine data from that column
I get all subfolders and all files but I get 5 times as much as I should.
L column is where I get all my data and Insert into Identical Master File (into L column).
I have 5 files - I should get 5 items in the last column, I simply add new folder in it, and same files(copied), so now I should get 10 items in the last column, instead I get 50.
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range, r As Range
Set Wb = ThisWorkbook: Wb.Sheets(2).Range("L:L").ClearContents
Dim FSO As Object, fld As Object, Fil As Object
Dim wbkCS As Workbook
Dim FolderPath As String
Dim fsoFile As Object
Dim fsoFol As Object
Dim fileName As String
Dim sWb As Workbook
Dim MatchingColumn As Range
Dim MatchingRowNb As Long
MsgBox "Choose a folder: "
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\Users\"
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox "No folder selected! Exiting script."
Exit Sub
End If
FolderPath = .SelectedItems(1)
End With
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath + "\"
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(FolderPath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(FolderPath).SubFolders
For Each fsoFile In fsoFol.Files
If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xlsx" Then
fileName = fsoFile.Name
Application.ScreenUpdating = False
MyDir = FolderPath 'fld
fileName = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While fileName <> ""
Set sWb = Workbooks.Open(fileName)
With sWb.Worksheets(2)
Rws = .Cells(Rows.Count, 12).End(xlUp).Row
Set Rng = Range(.Cells(5, 1), .Cells(Rws, 12))
End With
With Wb.Worksheets(2)
Set MatchingColumn = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
For Each r In Rng.Rows
If r.Cells(1, 1).Value2 <> vbNullString Then 'Ignoring empty rows
If r.Rows.Hidden = False Then
'We find the row where the Ids matche
MatchingRowNb = Application.Match(r.Cells(1, 1).Value2, MatchingColumn, False)
'We add the current value in the cell with the new value comming from the other file
.Cells(4 + MatchingRowNb, 12).Value2 = .Cells(4 + MatchingRowNb, 12).Value2 + r.Cells(1, 12).Value2
End If
End If
Next
End With
sWb.Close SaveChanges:=True
Application.DisplayAlerts = True
fileName = Dir()
Loop
End If
Next
Next
End If
End Sub
You're using both FSO and Dir() to loop over the files, so that's why you're getting the same files over and over.
When your sub ends up doing a bunch of things (particularly when one thing is nested in another, and so on) then it's best to consider splitting it up, so you can concentrate on the one thing that's giving you problems, without all the other things "getting in the way".
Here's a stripped-down version to show what I mean. It works but for clarity doesn't have your file processing code.
Option Explicit
Sub LoopThroughFolder()
Dim Wb As Workbook, sWb As Workbook
Dim FolderPath As String
Dim colFiles As Collection, f
'get a folder
FolderPath = ChooseFolder()
If Len(FolderPath) = 0 Then
MsgBox "No folder selected: exiting"
Exit Sub
End If
'find all excel files in subfolders of that folder
Set colFiles = FileMatches(FolderPath, "*.xlsx")
If colFiles.Count = 0 Then
MsgBox "No xlsx files found"
Exit Sub
End If
Set Wb = ThisWorkbook
Wb.Sheets(2).Range("L:L").ClearContents
'loop over the files we found
For Each f In colFiles
Set sWb = Workbooks.Open(f.Path)
'process the file here
sWb.Close SaveChanges:=True
Next f
End Sub
Function ChooseFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose a folder"
.InitialFileName = "C:\Users\"
.AllowMultiSelect = False
If .Show = -1 Then
ChooseFolder = .SelectedItems(1)
If Right(ChooseFolder, 1) <> "\" Then _
ChooseFolder = ChooseFolder + "\"
End If
End With
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function FileMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
For Each f In fldr.Files 'get files in folder
If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
Next f
If subFolders Then 'get subfolders for processing?
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
Loop
Set FileMatches = colFiles
End Function
I have split the directory in column A and filename in Column B. Trying to loop a macro to open all the files in the columns.
Using the codes below, it opens only the first file. not sure where I had gone wrong. the codes are as below:
Sub openfiles()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Dim wb As Workbook
Dim path As Worksheet
Dim row As String
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = Dir(directory & path.Range("B" & CStr(row)))
Do While fileName <> ""
Workbooks.Open (directory & Dir(directory & path.Range("B" & CStr(row))))
row = row + 1
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
After running, I would except all the files to be open so that I can proceed with other macros.
update:
here's the screenshot as requested, I can do with the directory and filename in one column.
Try this:
I prefer using this simple Method in case I already have all the file list in Excel.
Option Explicit
Sub openfiles()
Dim i As Long
Dim wb As Workbook
Dim path As Worksheet
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To path.Range("A2").End(xlDown).row
If Len(Dir(path.Range("A" & i) & path.Range("B" & i))) > 0 Then
Workbooks.Open (path.Range("A" & i) & path.Range("B" & i))
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Moving on to your code:
I usually resort to this method when I have to open all the files in a Particular folder or I don't have the Name of the File. Because this way you can pass on a Wildcard. So if you want to open all the Workbooks of folder O:\Common\ use this:
Sub openfiles()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Dim wb As Workbook
Dim path As Worksheet
Dim row As String
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = Dir(directory & "*.*")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
row = row + 1
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Problem: the problem with your code was, you were passing a Specific File Name to the variable filename, that's why you were only getting one file.
You still want to use your code, Here it is without DIR, unused variables and a bit less complicated.
Sub openfiles()
Dim directory As String
Dim fileName As String
Dim row As String
Set path = ThisWorkbook.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = path.Range("B" & CStr(row))
Do While fileName <> vbNullString
Workbooks.Open (directory & "\" & fileName)
row = row + 1
directory = path.Range("A" & CStr(row))
fileName = path.Range("B" & CStr(row))
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'm trying to run macro from file "A: that include Sheet named "Filter_Criteria" on multiple Worksheets from specific folder.
In each "B%" Worksheet from selected folder data from Sheet "Data" shall be filtered by range Sheet "Filter_Criteria" from file A and send back to Sheet "Output" file "B%".
Issue is that non of files from folder is being filtered and I got to results in any "B%" Worksheet.
Macro goes from the beginning to the end with no issues.
Inside-macro code works fine while running it on each file with:
Set Data_sh = ActiveWorkbook.Sheets("Data")
Set Output_sh = ActiveWorkbook.Sheets("Output")
But I cannot understand what is wrong with current changes.
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Dim Filter_Criteria_Sh As Worksheet
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
Set Filter_Criteria_Sh = ThisWorkbook.Sheets("Filter_Criteria")
'Folder with Worksheets
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'New Excel Process
Set eApp = New Excel.Application: eApp.Visible = False
fileName = Dir(folderName & "\*.*")
Do While fileName <> ""
'Update status bar to indicate progress
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
'Filter Data Macro
Dim Data_sh As Worksheet
Dim Output_sh As Worksheet
Set Data_sh = wb.Sheets("Data")
Set Output_sh = wb.Sheets("Output")
Output_sh.UsedRange.Clear
Data_sh.AutoFilterMode = False
Dim Emp_list() As String
Dim n As Integer
n = Application.WorksheetFunction.CountA(Filter_Criteria_Sh.Range("A:A")) - 2
ReDim Emp_list(n) As String
Dim i As Integer
For i = 0 To n
Emp_list(i) = Filter_Criteria_Sh.Range("A" & i + 2)
Next i
Data_sh.UsedRange.AutoFilter 2, Emp_list(), xlFilterValues
Data_sh.UsedRange.Copy Output_sh.Range("A1")
Data_sh.AutoFilterMode = False
MsgBox ("Data has been Copied")
wb.Close SaveChanges:=False
Debug.Print "Processed " & folderName & "\" & fileName
fileName = Dir()
Loop
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
MsgBox "Completed executing macro on all workbooks"
End Sub
I expect that 'Filter Data Macro will filter data in each file with filter criteria stored in Worksheet "A"
wb.Close SaveChanges:=False
You're not saving any changes you make to the workbooks.