Below script works perfect for importing multiple text files without duplicate header. But, requirement is paste the data in second row of worksheet. In first row, there is Import button for calling macro. But, as soon as execution completes first row is vanished and data is pasted.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim sFolder As String, vDB, Ws As Worksheet
Dim rngT As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
sFolder = "G:\Team Learning\vbapractice\Dunning\Import\"
Set folder = fso.GetFolder(sFolder)
' set the starting point to write the data to
'Worksheets("Sheet1").Activate
'Set Ws = ActiveSheet
Set Ws = Sheets("Data")
'Set cl = ActiveSheet.Cells(1, 1)
Ws.Cells.Clear
' Loop thru all files in the folder
For Each file In folder.Files
i = i + 1
Workbooks.Open Filename:=sFolder & file.Name, Format:=1
With ActiveWorkbook.ActiveSheet
If i = 1 Then
vDB = .UsedRange
Else
vDB = .UsedRange.Offset(1)
End If
End With
ActiveWorkbook.Close
Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2) ' it's lastrow +1
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next file
Ws.Range("a1").EntireRow.Delete
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
Related
Yesterday i have been provided with a wonderful code by #VBasic2008 that is working perfectly fine.
In a parent directory if there are 500 subfolders, the code lists down the names of each subfolder in excel sheet and also count number of files available in each subfolder and return the value in excel sheet as well and by this way I am able to verify which folders have how many files in it.
However, I request I need to add one more step in it which is difficult for me.
I have noticed that within each subfolders there are 3 to 4 more folders and the files are organized in these folders extension wise (see below screenshot). means in each subfolders there are (Zip) (Word) (PDF) (XML) etc.
Is there any possibility where the code can also read these folders which are in each subfolder and can return the answer like mentioned below
If the result is not possible the way i suggested above than any format will be okay. but the only requirement is that it can read the folder properties within each subfolder and can return result.
Sub ListSubfolders()
' Define constants.
Const FolderPath As String = "E:\2022\"
' Reference the folder.
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then
MsgBox "The folder """ & FolderPath & """ doesn't exist.", vbCritical
Exit Sub
End If
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
' Reference the first cell.
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range
Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
' Write the folder properties.
' If you don't want this, then out-comment it but also copy the line
' 'Set fCell = fCell.Offset(1)' to the bottom of the loop.
fCell.Value = fsoFolder.Name
fCell.Offset(, 1).Value = fsoFolder.Files.Count
' Write the subfolders' properties.
Dim fsoSubfolder As Object
For Each fsoSubfolder In fsoFolder.SubFolders
Set fCell = fCell.Offset(1)
fCell.Value = fsoSubfolder.Name
fCell.Offset(, 1).Value = fsoSubfolder.Files.Count
Next fsoSubfolder
End Sub
This will be much appreciated.
I can not see the images that you put in your question, but you can do a recursive function to count all files in subfolders
In example bellow, in first cell of each subdirectory is put a number indicating the sublevel, then in column of that sublevel is the name and the total of files is in the next column.
Sub CountAllFiles()
Const FolderPath As String = "E:\2022\"
' Reference the folder.
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then
MsgBox "The folder """ & FolderPath & """ doesn't exist.", vbCritical
Exit Sub
End If
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
' Reference the first cell.
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range
Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
' Write the folder properties.
' If you don't want this, then out-comment it but also copy the line
' 'Set fCell = fCell.Offset(1)' to the bottom of the loop.
fCell.Value = fsoFolder.Name
fCell.Offset(, 1).Value = fsoFolder.Files.Count
' Write the subfolders' properties.
Dim fsoSubfolder As Object
For Each fsoSubfolder In fsoFolder.SubFolders
Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
fCell.Value = fsoSubfolder.Name
fCell.Offset(, 1).Value = fsoSubfolder.Files.Count
Call countFiles(ws, fCell.Row, fsoSubfolder)
Next fsoSubfolder
End Sub
Sub countFiles(ByVal ws As Worksheet, ByVal pRow As Integer, ByVal pFsoSubfolder As Object)
Dim col As Integer
Dim totCol As Integer
Dim foundName As Boolean
For Each fsoSubfolder In pFsoSubfolder.SubFolders
' find subfolder name in columns
totCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
foundName = False
For col = 3 To totCol
If ws.Cells(1, col).Value = fsoSubfolder.Name Then
foundName = True
Exit For
End If
Next col
If Not foundName Then
ws.Cells(1, col).Value = "'" & fsoSubfolder.Name
End If
ws.Cells(pRow, col).Value = "'" & fsoSubfolder.Files.Count
Call countFiles(ws, pRow, fsoSubfolder)
Next fsoSubfolder
End Sub
I created a macro to rename files, but received this error:
Run-time error 53 File not found
But if I keep my cursor, it picks my location path correctly
"Name folder & Curname As folder & Newname"
Sub getname()
Dim folder As String
mfolder = Sheets("Sheet1").Cells(1, 2).Value
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
i = 3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(mfolder)
For Each objFile In objFolder.Files
Sheets("Sheet1").Cells(i, 1).Value = objFile.Name
i = i + 1
Next objFile
End Sub
Sub reName()
Dim mfolder As String
Dim CurName As String
Dim NewName As String
Dim i As Integer
i = 3
mfolder = Sheets("Sheet1").Cells(1, 2).Value
Do While Sheets("Sheet1").Cells(i, 1).Text <> "" And Sheets("Sheet1").Cells(i, 2).Text <> ""
CurName = Sheets("Sheet1").Cells(i, 1).Text
NewName = Sheets("Sheet1").Cells(i, 2).Text
Name mfolder & CurName As mfolder & NewName
i = i + 1
Loop
MsgBox ("Complete")
End Sub
As a rule of thumb I would always use early binding of Microsoft scripting runtime. This gives you access to intellisense and other benefits when using external references.
Tools >> references
Once added you import the object reference as follows.
dim fso as filesystemobject
set fso = new filesystemobject
this allows you to do things like this.
dim fldr as fldr
set fldr = fso.getfolder("c:\test_folder")
and iterating through files
dim fl as file
for each fl in fldr.files
do something
next fl
It always helps me personally to see what options are available when using a new reference in VBA .
(when using late binding like you are you don't have this luxury)
and mainly renaming files
fldr.move("C:\test_folder2")
In my opinion you should store the path of the file
objFile.path not objFile.Name
this would store something like C:\test\test.text
so fix with getting the list of files
Function list_files():
' log all files
Dim fso As filesystemobject
Set fso = New filesystemobject
Dim fldr As fldr
Set fldr = fso.getfolder("c:\test_folder")
Dim fl as file
Dim ws As Worksheet
Set ws = Worksheets("sheet1")
Dim i As Integer
i = 2
For Each fl In fldr.Files
ws.Cells(i, 1) = fl.Path
Next fl
End Function
and renaming
Function rename_files():
' log all files
Dim fso As filesystemobject
Set fso = New filesystemobject
Dim fl As file
Dim ws As Worksheet
Set ws = Worksheets("sheet1")
Dim lr As Integer
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lr
If ws.Cells(x, 2) <> "" Then
Set fl = fso.getfile(ws.Cells(x, 1))
fl.Move (ws.Cells(x, 2))
End If
Next x
End Function
Something else to note is that when iterating through cells its always best practice to use something along the lines of this.
dim ws as worksheet
set ws = worksheets("Sheet1") ' get the worksheet
dim lr as integer ' create lr interger reference
lr = ws.cells(rows.count,1).end(xlup).row
for x = 2 to lr
'do something
next x
lets break down whats happening here.
ws.cells(rows.count,1).end(xlup).row
ws in the worksheet
cells in the cells
rows.count get the last row
1 in column one
so....
ws.cells(rows.count,1) is referencing ALL cells in column 1
then....
.end(xlup) goes upwards to where the data starts (or the blank lines end)
row logs the row number
Then when you do your for loop you are not checking for the empty cells as you already know where it is.
for x = 2 to lr 'the last row in the data with data in it.
if ws.cells(x,2) <> "" then
'do something because column 1 and 2 both have no value in the cell
end if
next x
hope this helps somewhat
I am trying to come up with a routine that copies only certain files out of a directory, and all sub-directories, and pastes each copied file into a destination directory. I came up with the code below, which copies all files, in a filtered list, into a destination folder, but I can't figure out how to do a recursive loop through the hierarchy. Any guidance on this would be greatly appreciated.
Sub CopyFilteredFiles()
Dim rng As Range, cell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim lastChar As Integer
Dim fileName As String
DestinationFolder = "C:\Users\ryans\OneDrive\Desktop\AllYAML\"
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
Set rng = Range("D14:D" & LastRow)
Set FSO = CreateObject("scripting.filesystemobject")
For Each cell In rng.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" Then
CopyFile = cell.Value
Debug.Print cell.Value
lastChar = InStrRev(CopyFile, "\")
fileName = Mid(CopyFile, lastChar + 1, 199)
On Error Resume Next
FSO.CopyFile Source:=CopyFile, Destination:=DestinationFolder & fileName
End If
Next cell
End Sub
I've built an Excel Macro which takes the first sheets from all XLS files in a selected folder (including XLS files in any sub-folders) and copies the sheets onto a single sheet in a new Workbook. The code seems to work fine for the most part and I intend to use it to merge thousands of Excel sheets into a single file.
However the problem is that the loop just stops working at some point, with no errors raised. Sometimes it's a couple of hundred files, sometimes more. But the process seems to be unreliable and I can't tell why.
This is my code (I call the Merge macro which in turn calls the DoFolder Sub):
Sub Merge()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\XLSfiles"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim unusedRow As Long 'used for writing the file path info before each copied sheet
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
ThisWB = ActiveWorkbook.Name
Set shtDest = ActiveWorkbook.Sheets(1)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
ActiveWindow.WindowState = xlMinimized
For Each File In Folder.Files
' Operate on each file
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(File)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1),Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If
Cells(unusedRow, 1) = File
Application.StatusBar = File
Next
Range("A1").Select
End Sub
What am I missing?
Try this:
Instead of copying ranges, you can simply set their value
Do not use Cells when working with multiple sheets; always explicitely state the object/sheet whose Cells you like to address
Sample that worked for me:
For Each fi In f.Files
If InStr(1, Right(fi.Name, 5), ".xls") > 0 Then
Set Wkb = Workbooks.Open(fi)
Set ws = Wkb.Sheets(1)
rowCount = ws.UsedRange.Rows.Count
colCount = ws.UsedRange.Columns.Count
ranString = shtDest.Cells(curRow, 1).Address & ":" & shtDest.Cells(curRow + rowCount, colCount).Address
Set ran = ws.Range(ws.Cells(2, 1).Address, ws.Cells(rowCount, colCount).Address)
Set destRan = shtDest.Range(ranString)
destRan.Value = ran.Value
curRow = curRow + rowCount
Wkb.Close False
End If
Next fi
It may look a bit long-winded building a range string first, but it made debugging easier.
I am trying to create For Each loop for a several workbooks; however I am not able to set the workbook name in the array and thus resulted into this. I'm stuck in trying to concatenate the workbook name.
Here's my code:
'Open all .csv file in folder location
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
For Each objFile In objFolder.Files
If InStr(objFile, ".csv") Then
Workbooks.Open (objFile)
End If
Next
' Declare variables
Dim WrkBkPrm As Workbook
Dim WrkBkSrc As Workbook
Dim WrkShtPrm As Worksheet
Dim WrkShtSrc As Worksheet
Dim TextSrc(4) As String
Dim SrcRng As Range
Dim DRng As Range
' Assign values to TextSrc() Array
TextSrc(0) = Cable
TextSrc(1) = Care
TextSrc(2) = MSD
TextSrc(3) = Business
'Set WrkBkPrm and WrkShtPrm values
Set WrkBkPrm = Workbooks("MasterFile" & ".xlsm")
Set WrkShtPrm = WrkBkPrm.Worksheets("Canvas")
'Activate Canvas Sheet
WrkBkPrm.Activate
WrkShtPrm.Select
Application.ScreenUpdating = False
'Start For Each Loop
For Each Src In TextSrc()
Set WrkBkSrc = Workbooks(Src & ".csv")
Set WrkShtSrc = WrkBkSrc.Worksheets(Src)
'Copy loop for 1st section
For i = 2 To 49
For j = 7 To 25
Set SrcRng = WrkShtSrc.Cells(i, j)
Set DRng = WrkShtPrm.Cells(i, j)
If SrcRng <> "" Then
DRng.Value = SrcRng.Value
End If
Next j
Next i
Next Src
Application.ScreenUpdating = True
I'd suggest you work on the file as soon as you get hold of the relevant info you need.
Something like:
Dim wb As Workbook
For Each objFile In objFolder.Files
If InStr(objFile.Name, ".csv") <> 0 Then
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & objFile.Name)
'~~> Do your cool stuff with the opened CSV File
wb.Close False '~~> Close without saving
Set wb = Nothing '~~> Clean up although most of the time not necessary
End If
Next
As for the route you took, for you to use For Each Loop on TxtSrc, you need to declare it as variant.
Something like:
Dim TxtSrc As Variant, Src As Variant
TxtSrc = Array("Cable", "Care", "MSD", "Business")
For Each Src In TxtSrc
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & Src & ".csv")
'~~> More cool stuff here
wb.Close False
Set wb = Nothing
Next
It is important that provide the correct argument for the Workbook Open Method.
You should always include the complete path in string format. HTH.