I have an issue with the below code. It seems to work fine but apparently it is not able to move to the next file in the directory given; it gets in fact stuck to the first file, and it reopens it, without being able to move on to the next one. Any help super appreciated!
Sub Cash_Line_Check(strTargetPath)
Dim i As Long
Dim sPath As String
Dim sFil As String
Dim FolderPath As String
Dim diaFolder As FileDialog
Dim CurrReturnColumn As Range, TotReturnColumn As Range, VarTotReturnColumn As Range, CashRow As Range
Dim oWbk As Workbook
'Open the file dialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.InitialFileName = strTargetPath
diaFolder.Show
FolderPath = diaFolder.SelectedItems(1)
'Without wanting to use the promp, use the below line:
'FolderPath = strTargetFolder
'Cycle through spreadsheets in selected folder
sPath = FolderPath & "\" 'location of files
sFil = Dir(sPath & "*.xls") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
sFilTop20 = Dir(sPath & "TOP20" & "*.xls")
If (Len(sFilTop20) > 0) Then GoTo loopline
Set oWbk = Workbooks.Open(sPath & "\" & sFil) 'opens the file
i = 1 'Selects the sheet to be analysed'
'Perform Check and Record those funds adjusted
With oWbk.Worksheets(i)
Set CurrReturnColumn = .UsedRange.Find("Currency", , xlValues, xlWhole, xlByColumns)
Set TotReturnColumn = .UsedRange.Find("Portfolio", , xlValues, xlWhole, xlByColumns) 'Looks by columns
Set VarTotReturnColumn = .UsedRange.Find("Variation", , xlValues, xlWhole, xlByRows) 'Looks by rows
Set CashRow = .UsedRange.Find("[Cash]", , xlValues, xlWhole, xlByRows)
If .Cells(CashRow.Row, CurrReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, CurrReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, TotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, TotReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, VarTotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, VarTotReturnColumn.Column).Value = "-"
End If
End With
oWbk.Close True
sFil = Dir(sPath)
loopline:
Loop
End Sub
Different approach to loop through files I use.
Please note you need to check Microsoft Scripting Runtime in Tools>References
Sub find_reports()
Dim fname As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder
strPath = ThisWorkbook.Path
fname = ThisWorkbook.Name
Set objFolder = objFSO.GetFolder(strPath)
'If the folder does not contain files, exit the sub
If objFolder.Files.Count = 0 Then
MsgBox "No files in Folder", vbExclamation
Exit Sub
End If
'Loop through each file in the folder
For Each objFile In objFolder.Files
Debug.Print "Folder:" & strPath, "Filename: " & fname
Next objFile
End Sub
Here is a basic way to loop through all Excel files within a given folder:
Sub LoopExcelFiles()
Const xlsPath = "x:\ExcelTests"
Dim fName As String
fName = Dir(xlsPath & "\*.xl*") 'Find the first file
Do While fName <> "" 'keep looping until file isn't found
'do "whatever you gotta do" with each file here:
Debug.Print "Folder:" & xlsPath, "Filename: " & fName
fName = Dir() 'Find the next file (same criteria)
Loop
End Sub
Here is more on the Dir function.
Related
I have below VBA code that divided for tWo. First part of the code collect data from file directory and paste it on excel file (file name, path & modified date).
Second part of the code collect all txt file in the folder and marge them to one list in the same sheet.
I tried to improve my code to support more than one folder source and to combine both codes to one ( I joined two different codes to one) but I failed to do it. Any idea how to modified it?
Thanks,
Code:
Sub list()
'adding file name, path & last modify date
Dim FSO As Scripting.FileSystemObject
Dim FileItem As Scripting.File
SourceFolderName = "\\HA04HUCM0002\TestLog\LOT\avi_tests"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("c2:e2") = Array("text file", "path", "Date Last Modified")
i = 3
For Each FileItem In SourceFolder.Files
Cells(i, 3) = FileItem.Name
Cells(i, 4) = FileItem
Cells(i, 5) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
'combain txt data into one sheet
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "" & "*.txt")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "no txt files ", , "Kutools for Excel"
End Sub
To process another folder, simply ask the User if they want to run the code again.
Application.ScreenUpdating = True
If MsgBox("Do you want to process another folder?", vbYesNoCancel, "Kutools for Excel") = vbYes Then
Call list
End If
Good afternoon,
I have tried searching different forums to no avail.
I have the below VBA code that will loop through all files in a folder and generate in a msge box the total number of rows of every file looped in that folder.
What I need your help on if possible is generate a summary report.
Ideally
The summary report will show File name and show how many rows with data in column H.
Sub LoopThroughFiles()
Dim folderPath As String
folderPath = ThisWorkbook.Path & "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
If Application.CountA(sh.Range("H:H")) > 0 Then
myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row
End If
Next
wb.Close False
Filename = Dir
Set wb = Nothing
Loop
MsgBox myCount
End Sub
You could try opening a "home" workbook where all values are stored. Basically, what you'll need to do is open a new workbook, and during your loop through each of the files, you'll paste the file path and the row count in the new workbook. Hopefully this will help, or at least give you an idea of how to do what you're trying to do. `
Sub LoopThroughFiles()
Dim folderPath As String
Dim summarySheet as Workbook
set summarySheet = workbook.add
folderPath = ThisWorkbook.Path & "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
If Application.CountA(sh.Range("H:H")) > 0 Then
myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row
End If
Next
wb.Close False
summarySheet.activate
Range("A:A").insert Shift:=xlDown
Cells(1,1) = Filename
Cells(1,2) = myCount
Filename = Dir
Set wb = Nothing
Loop
MsgBox myCount
End Sub`
As the title says, I'm trying to push contents of a range of cells from a source workbook to the same range in a target (closed) workbook. I'm using the following code:
Option Explicit
Sub UpdateAdminBook()
Dim MyPath As String
Dim MyFile As String
Dim Wkb As Workbook
Dim Cnt As Long
Application.ScreenUpdating = False
MyPath = "C:FILEPATH\" 'change the path accordingly
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "Administration.xlsx")
Cnt = 0
Do While Len(MyFile) > 0
Cnt = Cnt + 1
Set Wkb = Workbooks.Open(MyPath & MyFile)
Wkb.Worksheets("Administration").Range("D18:D37").Value = ActiveWorkbook.Sheets("Administration").Range("D18:D37") 'change the new value accordingly
Wkb.Close savechanges:=True
MyFile = Dir
Loop
If Cnt > 0 Then
MsgBox "Completed...", vbExclamation
Else
MsgBox "No files were found!", vbExclamation
End If
Application.ScreenUpdating = True
End Sub
I'm having trouble starting at "ActiveWorkbook" and I keep getting "TRUE" or blanks. Any idea how I can fix this?
When you open a workbook, it becomes the active workbook, rather than the original workbook. Change to this
Dim wbSrc As Workbook
Set wbSrc = ActiveWorkbook
'...
Do ...
' ...
Set Wkb = Workbooks.Open(MyPath & MyFile)
Wkb.Worksheets("Administration").Range("D18:D37").Value = wbSrc.Sheets("Administration").Range("D18:D37") 'change the new value accordingly
you could assume your copying range as reference in a With - End With block
Sub UpdateAdminBook()
Dim MyPath As String
Dim MyFile As String
Dim Cnt As Long
Application.ScreenUpdating = False
MyPath = "C:FILEPATH\" 'change the path accordingly
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "Administration.xlsx")
With ActiveWorkbook.Sheets("Administration").Range("D18:D37")
Cnt = 0
Do While Len(MyFile) > 0
Cnt = Cnt + 1
Workbooks.Open(MyPath & MyFile).Worksheets("Administration").Range("D18:D37").Value = .Value 'change the new value accordingly
ActiveWorkbook.Close savechanges:=True
MyFile = Dir
Loop
End With
If Cnt > 0 Then
MsgBox "Completed...", vbExclamation
Else
MsgBox "No files were found!", vbExclamation
End If
Application.ScreenUpdating = True
End Sub
I was working with a vba and I'm trying to open all excel files in a folder (about 8-10) based on cell values. I was wondering if this is the right approach to opening it, it keeps giving me syntax error where I wrote the directory. and when I rewrote that section, the vba only shot out the msgbox which meant it had to have looped and did something right? but didn't open any files. Any information will help. Thank you guys so much for taking the time to help me in any way.
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
This worked for me perfectly
Sub OpenFiles()
Dim search As Worksheet
Dim customer As Range
Dim customerfolder As Range
Dim QualityHUB As Workbook
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = Worksheets("Search")
Set customer = Worksheets("Search").Range("$D$1")
Set customerfolder = Worksheets("Search").Range("$D$3")
With QualityHUB
If IsEmpty((customer)) And IsEmpty((customerfolder)) Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
End With
With QualityHUB
Dim MyFolder As String
Dim MyFile As String
Dim Directory As String
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\"
MyFile = Dir(Directory & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End With
End Sub
one of the issue was, you had to write
Workbooks.Open Filename:=Directory & MyFile
instead of
Workbooks.Open Filename:=MyFile
Corrected some issues with your code and cleaned it up, give this a try. I think the big issue was you had an extra double-quote, and you missing the ending \ in the Directory line:
Sub OpenFiles()
Dim QualityHUB As Workbook
Dim search As Worksheet
Dim customer As String
Dim customerfolder As String
Dim Directory As String
Dim MyFile As String
'setting variable references
Set QualityHUB = ThisWorkbook
Set search = QualityHUB.Worksheets("Search")
customer = search.Range("$D$1").Value
customerfolder = search.Range("$D$3").Value
If Len(Trim(customer)) = 0 Or Len(Trim(customerfolder)) = 0 Then
MsgBox "Please Fill out Customer Information and search again"
Exit Sub
End If
Directory = "O:\LAYOUT DATA\" & customer & "\" & customerfolder & "\" '<--- This requires the ending \
MyFile = Dir(Directory & "*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open Filename:=Directory & MyFile
MyFile = Dir()
Loop
MsgBox "Files Open for " + customerfolder + " complete"
End Sub
I found this code online and it will open all the excel files in a folder, you can adapt the code to apply a function to the workbook, once it is open.
Option Explicit
Type FoundFileInfo
sPath As String
sName As String
End Type
Sub find()
Dim iFilesNum As Integer
Dim iCount As Integer
Dim recMyFiles() As FoundFileInfo
Dim blFilesFound As Boolean
blFilesFound = FindFiles("G:\LOCATION OF FOLDER HERE\", _
recMyFiles, iFilesNum, "*.xlsx", True)
End Sub
Function FindFiles(ByVal sPath As String, _
ByRef recFoundFiles() As FoundFileInfo, _
ByRef iFilesFound As Integer, _
Optional ByVal sFileSpec As String = "*.*", _
Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean
Dim iCount As Integer '* Multipurpose counter
Dim sFileName As String '* Found file name
Dim wbResults, file, WS_Count, i, gcell, col, finRow, wbCodeBook As Workbook, lCount, name, looper
Dim WorksheetExists
Set wbCodeBook = ThisWorkbook
'*
'* FileSystem objects
Dim oFileSystem As Object, _
oParentFolder As Object, _
oFolder As Object, _
oFile As Object
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oParentFolder = oFileSystem.GetFolder(sPath)
If oParentFolder Is Nothing Then
FindFiles = False
On Error GoTo 0
Set oParentFolder = Nothing
Set oFileSystem = Nothing
Exit Function
End If
sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
'*
'* Find files
sFileName = Dir(sPath & sFileSpec, vbNormal)
If sFileName <> "" Then
For Each oFile In oParentFolder.Files
If LCase(oFile.name) Like LCase(sFileSpec) Then
iCount = UBound(recFoundFiles)
iCount = iCount + 1
ReDim Preserve recFoundFiles(1 To iCount)
file = sPath & oFile.name
name = oFile.name
End If
On Error GoTo nextfile:
Set wbResults = Workbooks.Open(Filename:=file, UpdateLinks:=0)
''insert your code here
wbResults.Close SaveChanges:=False
nextfile:
Next oFile
Set oFile = Nothing '* Although it is nothing
End If
If blIncludeSubFolders Then
'*
'* Select next sub-forbers
For Each oFolder In oParentFolder.SubFolders
FindFiles oFolder.path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
Next
End If
FindFiles = UBound(recFoundFiles) > 0
iFilesFound = UBound(recFoundFiles)
On Error GoTo 0
'*
'* Clean-up
Set oFolder = Nothing '* Although it is nothing
Set oParentFolder = Nothing
Set oFileSystem = Nothing
End Function
Function SSCGetColumnCodeFromIndex(colIndex As Variant) As String
Dim tstr As String
Dim prefixInt As Integer
Dim suffixInt As Integer
prefixInt = Int(colIndex / 26)
suffixInt = colIndex Mod 26
If prefixInt = 0 Then
tstr = ""
Else
prefixInt = prefixInt - 1
tstr = Chr(65 + prefixInt)
End If
tstr = tstr + Chr(65 + suffixInt)
SSCGetColumnCodeFromIndex = tstr
End Function
Function GetColNum(oSheet As Worksheet, name As String)
Dim Endrow_Col, i
'For loop to get the column number of name
Endrow_Col = oSheet.Range("A1").End(xlToRight).Column
oSheet.Select
oSheet.Range("A1").Select
For i = 0 To Endrow_Col - 1 Step 1
If ActiveCell.Value <> name Then
ActiveCell.Offset(0, 1).Select
ElseIf ActiveCell.Value = name Then
GetColNum = ActiveCell.Column
Exit For
End If
Next i
End Function
Function ShDel(name As String)
End If
End Function
I have a source folder that contains many xls files. I want to create a master file - collect all information into one database from all files in the given source.
The following code creates 2 columns in master file and enters 2 values from the given source file (one file):
Sub getData()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String
myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx" 'Select first file
' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
Application.ScreenUpdating = True
End Sub
Now I want to loop through all files and save the values from cells "A10" and "C5" from each file in one database, so the loop should select the next row to save new values.
I have an idea how to loop through all files, but don't know how to switch to the next row:
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
Any help will be highly appreciated! :)
For simplicity, just use a counter:
scrFile = Dir(myPath & "*.xlsx")
n = 1 ' skip the first row with headers
Do While scrFile <> ""
n = n + 1
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' save the values of A10 and C5 of the given file in the next row
ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
msgbox n & " files imported."
BTW, you don't need to start a second Excel instance (CreateObject("Excel.Application")) just to open a second workbook. This will slow down your code a lot. Just open, read and close it. Address your master workbook not by ThisWorkbook but assign a varible to it:
Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
You need to recalculate last row in the loop wtih End() function.
Like this for range .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
Or to have an integer .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
Give this a try :
Sub getData()
Application.ScreenUpdating = False
Dim XL As Excel.Application, _
WBK As Excel.Workbook, _
MS As Worksheet, _
scrFile As String, _
myPath As String
'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
With MS
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
End With
WBK.Close False
scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True
End Sub
I actually have a code here that will loop through each file and deposit the code into your main file. You are also able to choose the directory of the target folder.
Sub GatherData()
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strFolder).Files
Set objSubFolders = objFso.GetFolder(strFolder).subFolders
'Loop through each file in the folder
For Each objFile In objFiles
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8") 'here you can change the cells you need the data from
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
Next objFile
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub