I want to open, using VBA, a workbook from a certain path that includes a number, for example 2. Any variation I tried is not working.
The name of the workbook is in Hebrew except for the number, so I want the VBA code to base the file name on the number to open the file.
I have 4 letters in hebrew before the number. In Hebrew we write from right to left.
Here is my code:
Set WB1 = Workbooks.Open("C:\RESULTS\" 2 & ".xlsx")
Thanks for helping.
Try this
Dim sFound As String, fPath As String
fPath = "C:\RESULTS\"
sFound = Dir(fPath & "*2*.xlsx") 'get the first file in dir
If sFound <> "" Then
Set WB1 = Workbooks.Open(fPath & sFound)
End If
This works for me:
Option Explicit
Sub TestMe()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wbs As Workbook
Dim strExtension As String
Dim lngNumber As String
Dim lngAdditional As Long
Dim lngLenFile As Long
strExtension = ".xlsx"
lngNumber = 20
lngAdditional = 4
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Desktop\")
lngLenFile = Len(strExtension) + Len(lngNumber) + lngAdditional
For Each objFile In objFolder.Files
If Left(objFile.Name, Len(lngNumber)) = lngNumber And _
Right(objFile, Len(strExtension)) = strExtension And _
Len(objFile.Name) = lngLenFile Then
Debug.Print objFile.Name
Set wbs = Workbooks.Open(objFile)
End If
Next objFile
End Sub
The idea of the code is to make it flexible, thus, lngNumber and strExtension are added. It checks always for the size, as well as for right and left. Thus 24Some.xlsx would be different than 2Some.xlsx.
Debug.Print is added to see the file that is opened.
lngAdditional is added, for the additional 4 chars.
Related
I've managed to piece together this VBA which takes data from excel and turns it into .txt flat file. It works exactly as I need, but I would like to alter it so that the end result is saved as Unicode as opposed to ANSI.
I've done some reading and the answer I keep coming back to is to use FileSystemObject. I found a VBA on here that does the job perfectly, but I can't for the life of me work out how to incorporate it into my existing code. Any chance someone could throw me some pointers?
This is my current code:
' Defines everything first. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
' File name, path to save to and delimiter.
file = Sheets("Pricing").TextBox1 & ".txt"
If TextBox1.Value = "" Then MsgBox "What we calling it genius?", vbQuestion
If TextBox1.Value = "" Then Exit Sub
Path = "C:\Users\me.me\Desktop\Files\"
Delimeter = "|"
' The magic bit.
myFileName = Path & file
FN = FreeFile
Open myFileName For Output As #FN
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
Print #FN, Record
Next Row
Close #FN
MsgBox "BOOM! LOOKIT ---> " & myFileName
' Opens the finished file.
Dim fso As Object
Dim sfile As String
Set fso = CreateObject("shell.application")
sfile = "C:\Users\me.me\Desktop\Files\" & Sheets("Pricing").TextBox1 & ".txt"
fso.Open (sfile)
And this is what I've been trying to incorporate (HUGE thanks to MarkJ for posting this on another question):
Dim fso As Object, MyFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile("c:\testfile.txt", False,True) 'Unicode=True'
MyFile.WriteLine("This is a test.")
MyFile.Close
I just can't get it to work.
Please, test the next code. You did not answer my clarification question, but it works using the above comment assumptions. It take the file name, from an activeX text box situated on the sheet to be processed. The code should be faster than yours for big ranges, avoiding to iterate between all cells:
Sub SaveAsUnicode()
Dim shP As Worksheet, iRow As Long, Record As String, Delimeter As String
Dim file As String, myFileName As String, path As String, txtB As MSForms.TextBox
Dim rng As Range, lastCell As Range, arr, arrRow
Dim fso As Object, MyFile As Object, shApp As Object
Set shP = Worksheets("Pricinig")
Set txtB = shP.OLEObjects("TextBox1").Object 'it sets an activeX sheet text box
file = txtB.Text & ".txt"
If txtB.value = "" Then MsgBox "What we calling it genius?", vbQuestion: Exit Sub
Set lastCell = shP.cells.SpecialCells(xlCellTypeLastCell) 'last cell of the sheet
Set rng = shP.Range("A2", lastCell) 'create the range to be processed
arr = rng.value 'put the range in an array
path = "C:\Users\me.me\Desktop\Files\" 'take care to adjust the path!
myFileName = path & file
Delimeter = "|"
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(myFileName, False, True) 'open the file to write Unicode:
For iRow = 1 To UBound(arr) 'itereate between the array rows
arrRow = Application.Index(arr, iRow, 0) 'make a slice of the currrent arrray row
Record = Join(arrRow, Delimeter) 'join the iD obtained array, using the set Delimiter
MyFile.WriteLine (Record) 'write the row in the Unicode file
Next iRow
MyFile.Close 'close the file
'open the obtained Unicode file:
Set shApp = CreateObject("shell.application")
shApp.Open (myFileName)
End Sub
I tested the above code on a sheet using characters not supported in ANSI and it works as expected.
Please, send some feedback after testing it, or if my assumptions after reading your question are not correct...
#FaneDuru, this is what I ended up putting together, it's working great for me. Thanks again for all of your help.
Private Sub FlatButton_Click()
'Does all the setup stuff.
Dim fso As Object, MyFile As Object
Dim MyFileName As String
Dim txtB As MSForms.TextBox
Set shP = Worksheets("Pricing")
Set txtB = shP.OLEObjects("TextBox1").Object
file = txtB.Text & ".txt"
If txtB.Value = "" Then MsgBox "What we calling it?", vbQuestion: Exit Sub
' Defines the range. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
'File details.
path = "C:\Users\me.me\Blah\Blah\"
MyFileName = path & file
Delimeter = "|"
' The magic bit.
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(MyFileName, False, True) '<==== This defines the Unicode bit.
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
MyFile.WriteLine (Record)
Next Row
MyFile.Close
MsgBox "BOOM! ---> " & MyFileName
'Option to open the finished product.
If ActiveSheet.CheckBox2.Value = True Then
Set shApp = CreateObject("shell.application")
shApp.Open (MyFileName)
End If
End Sub
Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub
I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore
This question already has answers here:
Cycle through sub-folders and files in a user-specified root directory [duplicate]
(3 answers)
Closed 1 year ago.
I need to get the names of all the Excel files in a folder and then make changes to each file. I've gotten the "make changes" part sorted out. Is there a way to get a list of the .xlsx files in one folder, say D:\Personal and store it in a String Array.
I then need to iterate through the list of files and run a macro on each of the files which I figured I can do using:
Filepath = "D:\Personal\"
For Each i in FileArray
Workbooks.Open(Filepath+i)
Next
I had a look at this, however, I wasn't able to open the files cause it stored the names in Variant format.
In short, how can I use VBA to get a list of Excel filenames in a specific folder?
Ok well this might work for you, a function that takes a path and returns an array of file names in the folder. You could use an if statement to get just the excel files when looping through the array.
Function listfiles(ByVal sPath As String)
Dim vaArray As Variant
Dim i As Integer
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then Exit Function
ReDim vaArray(1 To oFiles.Count)
i = 1
For Each oFile In oFiles
vaArray(i) = oFile.Name
i = i + 1
Next
listfiles = vaArray
End Function
It would be nice if we could just access the files in the files object by index number but that seems to be broken in VBA for whatever reason (bug?).
You can use the built-in Dir function or the FileSystemObject.
Dir Function: VBA: Dir Function
FileSystemObject: VBA: FileSystemObject - Files Collection
They each have their own strengths and weaknesses.
Dir Function
The Dir Function is a built-in, lightweight method to get a list of files. The benefits for using it are:
Easy to Use
Good performance (it's fast)
Wildcard support
The trick is to understand the difference between calling it with or without a parameter. Here is a very simple example to demonstrate:
Public Sub ListFilesDir(ByVal sPath As String, Optional ByVal sFilter As String)
Dim sFile As String
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file name
sFile = Dir(sPath & sFilter)
'call it again until there are no more files
Do Until sFile = ""
Debug.Print sFile
'subsequent calls without param return next file name
sFile = Dir
Loop
End Sub
If you alter any of the files inside the loop, you will get unpredictable results. It is better to read all the names into an array of strings before doing any operations on the files. Here is an example which builds on the previous one. This is a Function that returns a String Array:
Public Function GetFilesDir(ByVal sPath As String, _
Optional ByVal sFilter As String) As String()
'dynamic array for names
Dim aFileNames() As String
ReDim aFileNames(0)
Dim sFile As String
Dim nCounter As Long
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file
sFile = Dir(sPath & sFilter)
'call it until there is no filename returned
Do While sFile <> ""
'store the file name in the array
aFileNames(nCounter) = sFile
'subsequent calls without param return next file
sFile = Dir
'make sure your array is large enough for another
nCounter = nCounter + 1
If nCounter > UBound(aFileNames) Then
'preserve the values and grow by reasonable amount for performance
ReDim Preserve aFileNames(UBound(aFileNames) + 255)
End If
Loop
'truncate the array to correct size
If nCounter < UBound(aFileNames) Then
ReDim Preserve aFileNames(0 To nCounter - 1)
End If
'return the array of file names
GetFilesDir = aFileNames()
End Function
File System Object
The File System Object is a library for IO operations which supports an object-model for manipulating files. Pros for this approach:
Intellisense
Robust object-model
You can add a reference to to "Windows Script Host Object Model" (or "Windows Scripting Runtime") and declare your objects like so:
Public Sub ListFilesFSO(ByVal sPath As String)
Dim oFSO As FileSystemObject
Dim oFolder As Folder
Dim oFile As File
Set oFSO = New FileSystemObject
Set oFolder = oFSO.GetFolder(sPath)
For Each oFile In oFolder.Files
Debug.Print oFile.Name
Next 'oFile
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
If you don't want intellisense you can do like so without setting a reference:
Public Sub ListFilesFSO(ByVal sPath As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
For Each oFile In oFolder.Files
Debug.Print oFile.Name
Next 'oFile
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Dim iIndex as Integer
Dim ws As Excel.Worksheet
Dim wb As Workbook
Dim strPath As String
Dim strFile As String
strPath = "D:\Personal\"
strFile = Dir(strPath & "*.xlsx")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For iIndex = 1 To wb.Worksheets.count
Set ws = wb.Worksheets(iIndex)
'Do something here.
Next iIndex
strFile = Dir 'This moves the value of strFile to the next file.
Loop
If all you want is the file name without file extension
Dim fileNamesCol As New Collection
Dim MyFile As Variant 'Strings and primitive data types aren't allowed with collection
filePath = "c:\file directory" + "\"
MyFile = Dir$(filePath & "*.xlsx")
Do While MyFile <> ""
fileNamesCol.Add (Replace(MyFile, ".xlsx", ""))
MyFile = Dir$
Loop
To output to excel worksheet
Dim myWs As Worksheet: Set myWs = Sheets("SheetNameToDisplayTo")
Dim ic As Integer: ic = 1
For Each MyFile In fileNamesCol
myWs.Range("A" & ic).Value = fileNamesCol(ic)
ic = ic + 1
Next MyFile
Primarily based on the technique detailed here: https://wordmvp.com/FAQs/MacrosVBA/ReadFilesIntoArray.htm
Regarding the upvoted answer, I liked it except that if the resulting "listfiles" array is used in an array formula {CSE}, the list values come out all in a horizontal row. To make them come out in a vertical column, I simply made the array two dimensional as follows:
ReDim vaArray(1 To oFiles.Count, 0)
i = 1
For Each oFile In oFiles
vaArray(i, 0) = oFile.Name
i = i + 1
Next
Sub test()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder1 = FSO.GetFolder(FromPath).Files
FolderPath_1 = "D:\Arun\Macro Files\UK Marco\External Sales Tool for Au\Example Files\"
Workbooks.Add
Set Movenamelist = ActiveWorkbook
For Each fil In folder1
Movenamelist.Activate
Range("A100000").End(xlUp).Offset(1, 0).Value = fil
ActiveCell.Offset(1, 0).Select
Next
End Sub
I need to find out the number of rows in each excel sheets under a folder .Google search shows that the below script works..but having very less knowledge on vb ,i could not resolve it.The script containe ''Wscript object.I think this works with out this object as well
The thing is under "c:\temp", i have 100 excel sheets(.xls). Need to find out number of rows in each file. Help needed from vb experts
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String = " "
' Specify folder.
strFolder = "c:\\temp" -----
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open(objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox(objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close()
End If
Next
' Clean up.
objExcel.Application.Quit()
Dts.TaskResult = ScriptResults.Success
End Sub
Make sure you're declaring the sub routine at the top with "Sub _()". Also, there are a few things that I believe are syntactically incorrect about this one. Try this instead:
Sub blah()
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String
V_FilePath = " "
' Specify folder.
strFolder = "c:\\temp"
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open (objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox (objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close
End If
Next
' Clean up.
objExcel.Application.Quit
Dts.TaskResult = ScriptResults.Success
End Sub
If you're doing this in VBA in an Excel Macro, perhaps this will work a bit better:
Sub LoopThroughFiles()
Dim strFile As String
Dim strPath As String
Dim colFiles As New Collection
Dim i As Integer
Dim rowCount As Integer
strPath = "C:\Users\[windows_username]\Documents\" 'Your path here
strFile = Dir(strPath)
While strFile <> ""
colFiles.Add strFile
strFile = Dir
Wend
'List filenames in Column A of the active sheet
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
ActiveSheet.Cells(i, 1).Value = colFiles(i)
Workbooks.Open strPath & colFiles(i)
rowCount = ActiveSheet.UsedRange.Rows.Count
Workbooks(colFiles(i)).Close
'Workbooks.Close
'ThisWorkbook.Close
ActiveSheet.Cells(i, 2).Value = rowCount
Next i
End If
End Sub
This would work
MsgBox(objFile.name + CStr(objRows.Count))