I have the following module to check the number of files contained in a folder and display a messagebox with the with the number of files:
Sub CheckFiles(strDir As String, strType As String)
Dim file As Variant, i As Integer
strDir = ThisWorkbook.Path & "\Source\"
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
file = Dir(strDir & strType)
While (file <> "")
i = i + 1
file = Dir
Wend
MsgBox i
End Sub
Files to look for (in separate module):
Call CheckFiles("", "File1*.xlsx")
Call CheckFiles("", "File2*.xlsx")
What I want to do is to only display messagebox if the number of files for File1 is not excaly 3 and the number of files for File2 is not excaly 2. This is what I'm having trouble doing? How can this be acheived?
Add the ChckNum as Third Parameter in the Subject and pass it in the Call Statement
Try:
Sub CheckFiles(strDir As String, strType As String, chknum As Integer)
Dim file As Variant, i As Integer
strDir = ThisWorkbook.path & "\Source\"
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
file = Dir(strDir & strType)
While (file <> "")
i = i + 1
file = Dir
Wend
If i <> chknum Then MsgBox i
End Sub
And
Call CheckFiles("", "File1*.xlsx", 3)
Call CheckFiles("", "File2*.xlsx", 2)
Related
I need help understanding why file name extraction from string only works every other time.
I've tried both right and mid. I've used before in other code with no problem. I'm useing msgbox for debugging.
Final outcome should be adding multiple file names to the bottom of a table
Private Sub ButtonAdd_Click()
Dim fd As FileDialog
Dim fName As String ' full path file name
Dim nextRow As Long
Dim filename As String ' extracted file name only
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Please select file to add"
fd.InitialFileName = ThisWorkbook.FullName
fd.AllowMultiSelect = True
fchosen = fd.Show
If fchosen = -1 Then
For i = 1 To fd.SelectedItems.Count
fName = fd.SelectedItems(i)
'filename = Right(fName, Len(fName) - InStrRev(filename, "\"))
filename = Mid(fName, InStrRev(filename, "\") + 1)
MsgBox (filename)
nextRow = Range("a" & Rows.Count).End(xlUp).row + 1
'Range("a" & nextRow) = filename
Next i
End If
End Sub
As Josh writes in the comments, you are using the wrong variable filename instead of fname. Another example of how nesting commands makes it difficult to find an error and how naming of variables matters.
Split the lines into two pieces and rename fname to something like fullFilename:
Dim fullFilename as string, filename as string, p as long
fullFilename = fd.SelectedItems(i)
p = InStrRev(fullFilename, "\")
if p > 0 then
filename = mid(fullFilename, p+1)
else
filename = fullFilename
End If
Now you can easily distinguish between the variable holding the full path and the one that has only the file name. And even if you mix something up, you can easily find the problem using the debugger
Take your pick
Get File Name From File Path
Option Explicit
Sub Sample()
MsgBox GetFilenameFromPath("C:\Temp\Myfile.Txt")
End Sub
Private Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath( _
Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Get File Name Without Extension
Option Explicit
Sub Sample()
Dim fName As String
fName = "C:\Temp\Myfile.Txt"
MsgBox GetFilenameFromPath(Left(fName, (InStrRev(fName, ".", -1, vbTextCompare) - 1)))
End Sub
Private Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath( _
Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
I am using VBA to search a network folder with typically about 4000 .txt files and move the bad ones that contain strings listed in an excel range, to another folder. Remaining good files are zipped and moved/scattered and the .txt's moved to a single folder.
Here is my code that takes many hours to run, probably due to the double looping. Please help me with changing this to run faster/more efficient.
Option Compare Text
Sub SDRFiles()
Dim lastRow As Integer
Dim Fldr As Object
Dim BaseFldr As String
Dim sdrDNU As String
Dim sdrDateFldr As String
Dim fDate
Dim FSO As Object
Dim FirstTwo As String
Dim NineTen As String
Dim Lead As String
Dim BadFile As Integer
Dim sdrFile As String
Dim fldExists As String
'Process SDR files. Move files off landing zone to working folder, pull out and store bad files,
'zip good files and move to each owner's folder, save good txt in Data Czar's folder.
'Landing zone
BaseFldr = "\\nasgw013pn\hedis_prod\SDR FILES"
'new SDR folder for files
fDate = Format(Date, "mmddyyyy")
'Processing fldr
sdrDateFldr = BaseFldr & "\" & fDate & "_" & shControl.cboMonth.Value & theCycle
fldExists = Dir(sdrDateFldr)
If fldExists = "" Then
MkDir sdrDateFldr
End If
'Move all files from landing zone to processing folder
Set FSO = CreateObject("scripting.filesystemobject")
extn = "\*.txt"
FSO.MoveFile Source:=BaseFldr & extn, Destination:=sdrDateFldr & "\"
'Do Not Use sub folder for bad files
sdrDNU = sdrDateFldr & "\DNU"
fldExists = Dir(sdrDNU)
If fldExists = "" Then
MkDir sdrDNU
End If
'Good Text File destination
TextFileFldr = fDate & "_" & shControl.cboMonth.Value & theCycle & "_txt"
TextFileDest = sdrDateFldr & "\" & TextFileFldr
fldExists = Dir(TextFileDest)
If fldExists = "" Then
MkDir TextFileDest
End If
'Bottom of bad file strings
lastRow = shSDR.Range("A" & Rows.Count).End(xlUp).Row
Set xFolder = FSO.GetFolder(sdrDateFldr)
'loop thru folder
For Each xFile In xFolder.Files 'About 4000 files. can vary
Fname = xFile.Name
FirstTwo = Left(Fname, 2)
NineTen = Mid(Fname, 9, 2)
Lead = Mid(Fname, 16, 2)
'range with list of bad strings
For Each Item In shSDR.Range("A2:A" & lastRow) 'about 10 strings. can vary
'Hold file from 1st loop and test. If bad file, move to Do Not Use (DNU) folder
If InStr(Fname, Item) > 0 Or _
(InStr(Fname, "PWOEY") > 0 And FirstTwo <> "OH") Or _
(InStr(Fname, "HNARST") > 0 And FirstTwo <> NineTen) Or _
(InStr(Fname, "FTANDHEIPANE") > 0 And FirstTwo <> Lead) Then
'bad file - move to DNU Folder
Name sdrDateFldr & "\" & Fname As sdrDNU & "\" & Fname
'Bad file indentified
BadFile = 1
'exit this loop if matched and get next file
Exit For
End If
Next Item
If BadFile = 0 Then
'Good file - zip it and move each txt file to same folder
Call Zipp(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), sdrDateFldr & "\" & Fname)
‘move good zipped file to its own specific folder – NY folder, FL folder TX folder etc.
Call MoveIt(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), Replace(Fname, "txt", "zip"))
End If
BadFile = 0
Next xFile
End Sub
'says function but it really a sub
Public Function Zipp(ZipName, FileToZip)
'Called by all modules to create a Zip File
‘Dim FSO As Object
Dim oApp As Object
If Len(Dir(ZipName)) > 0 Then Kill (ZipName)
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
dFile = Dir(FileToZip)
On Error Resume Next
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(CVar(ZipName)).CopyHere CVar(FileToZip)
DoEvents
'====HELP!!! ================Please help me with the following. It hangs sporadically, sometimes at
'============================file 200 or may the 1500th file. I have to esc esc and continue.
'============================For 10 to 20 files it seems to run fine
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CVar(ZipName)).Items.Count = 1
Application.Wait (Now + TimeValue("0:00:06"))
DoEvents
Loop
'=============================================================================
'=============================================================================
'USED ONLY BY Sub SDRFiles()
'THIS PART OF ZIPP SAVES THE .TXT FILE TO DATA CZAR'S FOLDER
'SDR Processing - Move text file
If SDR = "Y" And Len(Dir(FileToZip)) > 0 Then
SetAttr FileToZip, vbNormal
Name FileToZip As TextFileDest & "\" & dFile
End If
Set oApp = Nothing
‘Set FSO = Nothing
End Function
Sub MoveIt(PathZip, ZipFileName)
Dim rootPlusSubFolder As String
Dim NasState As Range
Dim NasLocation As String
Dim FSO As Object
'MOVE ZIPP FILES TO FOLDERS
'MOVE FILES TO IMP FOLDER - find state in extract name and MOVE file to that folder
'Bottom of state list
botRow = shNasMoves.Cells(shNasMoves.Rows.Count, 7).End(xlUp).Row
'Bottom of list of import folder names
NasBot = Sheets("NASMoves").Cells(Rows.Count, "A").End(xlUp).Address
'Look up state to get import folder path
Application.FindFormat.Clear
Set NasState = shNasMoves.Range("A1:" & NasBot).Find(What:=Left(ZipFileName, 2))
'if state found, get folder location URL
If Not NasState Is Nothing Then
NasLocation = NasState.Offset(0, 1).Value
'current month for sub folder file name
CurMonthFolder = "CS_" & theMo & "_" & theCycle & "\"
'Combined destination folder and sub folder name
rootPlusSubFolder = NasLocation & CurMonthFolder
Set FSO = CreateObject("scripting.filesystemobject")
'if CS Import SUB folder doesn't exist, create it - sometimes DIR sometimes FSO
If Not FSO.FolderExists(rootPlusSubFolder) Then
FSO.CreateFolder (rootPlusSubFolder)
End If
'Final dest Fldr
If Not FSO.FolderExists(rootPlusSubFolder & "\" & "SDR") Then
FSO.CreateFolder (rootPlusSubFolder & "\" & "SDR")
End If
'try to stop pop up
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
'Debug.Print rootPlusSubFolder & "SDR"
On Error Resume Next
'move file from Root to destination folder/sub folder
FSO.MoveFile PathZip, rootPlusSubFolder & "SDR\" & ZipFileName
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End If
End Sub
I'm completely new to VBA and had some trouble googling this problem cause variable has multiple meanings.
I am trying to open a file and assign its name to a variable. The file's name is never the same though I always download it to the same folder (one file in that folder only). The only recognizable thing about the file are 3 letters "ABC".
So far I managed to get opening the file to work but not assigning the non-standardized file name to a variable.
Sub openwb()
Dim wb As Workbook Dim directory As String
directory = "D:\Users\AAA\Desktop\Practice"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(directory)
For Each file In folder.Files
If Mid(file.Name, InStrRev(file.Name, ".") + 1) = "xlsm" Then
Workbooks.Open directory & Application.PathSeparator & file.Name
End If
Next file
End Sub
Public Sub RecordFileName()
Dim sPath As String, sFile As String
Dim wb As Workbook
sPath = "D:\Users\AAA\Desktop\Practice"
sFile = sPath & "*ABC*"
End Sub
Here is a function you can use. It will return the filename you are looking for, and you can specify a file pattern if you want to, or you can omit that argument and it will assume all files.
Function GetFullFileName(sFolder As String, Optional sPattern As String = "*") As String
Dim sFile As String
' ensure sFolder ends with a backslash
If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
sFile = Dir(sFolder & sPattern)
If sFile = "" Then
MsgBox "NOT FOUND: " & sFolder & sPattern
End
End If
GetFullFileName = sFolder & sFile
End Function
Usage:
MsgBox GetFullFileName("C:\Users\Fred\Documents")
Or
MsgBox GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
Or
sFullFile = GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
I have large number of .csv files in a folder and each file has few separation codes in them. Separation code usually will be 5 digit code eg: B82A6.
I have to copy files with a certain separation code and move them to a destination folder.
I am new to VBA. I've been searching for code to modify it to my use.
Sub Test()
Dim R As Range, r1 As Range
Dim SourcePath As String, DestPath As String, SeperationCode As String
SourcePath = "C:\Users\hr315e\Downloads\Nov_03_2019\"
DestPath = "C:\Users\hr315e\Downloads\Target\"
Set r1 = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each R In r1
SeperationCode = Dir(SourcePath & R)
Do While SeperationCode <> ""
If Application.CountIf(r1, SeperationCode) Then
FileCopy SourcePath & SeperationCode, DestPath & SeperationCode
R.Offset(0, 1).Value = SeperationCode
Else
MsgBox "Bad file: " & SeperationCode & " ==>" & SeperationCode & "<== "
End If
SeperationCode = Dir(SourcePath & "B82A6" & R.Value & "B82A6")
Loop
Next
End Sub
So, here's the code that should work for you.
As you can see, this is a version of code which I linked to you with small updates:
Sub GoThroughFilesAndCopy()
Dim BrowseFolder As String, DestinationFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim TempFileName As String
Dim CheckCode As String
Application.ScreenUpdating = False
' selecting the folder with files
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with files"
.Show
On Error Resume Next
Err.Clear
BrowseFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'BrowseFolder = "C:\Users\hr315e\Downloads\Nov_03_2019\"
' selecting the destination folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the the destination folder"
.Show
On Error Resume Next
Err.Clear
DestinationFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'DestinationFolder = "C:\Users\hr315e\Downloads\Target\"
CheckCode = "Some string" ' this is you check code
Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object
For Each FileItem In oFolder.Files 'looking through each file in selected forlder
TempFileName = ""
If UCase(FileItem.Name) Like "*.CSV*" Then 'try opening only .csv files
TempFileName = BrowseFolder & Application.PathSeparator & FileItem.Name ' getting the full name of the file (with full path)
If CheckTheFile(TempFileName, CheckCode) Then ' if the file passes the checking function
If Dir(DestinationFolder & Application.PathSeparator & FileItem.Name) = "" Then 'if the file doesn't exist in destination folder
FileCopy Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name ' it is copied to destination
Else ' otherwise, there are to options how to deal with it further
'uncomment the part you need below:
' this will Overwrite existing file
'FSO.CopyFile Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name
' this will get new name for file and save it as copy
'FileCopy Source:=TempFileName, Destination:=GetNewDestinationName(FileItem.Name, DestinationFolder)
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'////////////////////////////////////////////////////////////////////////
Function CheckTheFile(File As String, Check As String) As Boolean
Dim TestLine As String
Dim TestCondition As String
TestCondition = "*" & Check & "*" ' this is needed to look for specific text in the file, refer to Like operator fro details
CheckTheFile = False
Open File For Input As #1 ' open file to read it line by line
Do While Not EOF(1)
Line Input #1, TestLine ' put each line of the text to variable to be able to check it
If TestLine Like TestCondition Then ' if the line meets the condition
CheckTheFile = True ' then function gets True value, no need to check other lines as main condition is met
Close #1 ' don't forget to close the file, beacuse it will be still opened in background
Exit Function ' exit the loop and function
End If
Loop
Close #1 ' if condiotion is not found in file just close the file, beacuse it will be still opened in background
End Function
'////////////////////////////////////////////////////////////////////////
Function GetNewDestinationName(File As String, Destination As String) As String
Dim i As Integer: i = 1
Do Until Dir(Destination & Application.PathSeparator & "Copy (" & i & ") " & File) = "" ' if Dir(FilePath) returns "" (empty string) it means that the file does not exists, so can save new file with this name
i = i + 1 ' incrementing counter untill get a unique name
Loop
GetNewDestinationName = Destination & Application.PathSeparator & "Copy (" & i & ") " & File ' return new file name
End Function
Basically, there is one sub, which is mostly copy-paste from linked topic, and two simple functions.
I want to loop through a directory and group files by the filenames up until the first _ in the filename.
Files are structured by
Manager Name_Employee Name_Assessment.xlsx
I want this to group together strings up until the first underscore. I can't designate a character length because managers have different names.
I'm thinking changing the If Right(filename,4) statement should do what I want, but I can't specify a character limit.
Public Sub Move_Files()
Dim sourceFolder As String, fileName As String
Dim destinationFolder As String, foundDestinationFolder As String
Dim missingFolders As String
sourceFolder = "C:\Assessment\"
If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
'Loop through *.xls files in source folder
missingFolders = ""
fileName = Dir(sourceFolder & "*.xls")
While fileName <> vbNullString
**If Right(fileName, 4) = ".xlsx" Then**
destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1)
foundDestinationFolder = Find_Subfolder(sourceFolder, destinationFolder)
If foundDestinationFolder <> "" Then
Name sourceFolder & fileName As foundDestinationFolder & fileName
Else
missingFolders = missingFolders & vbCrLf & destinationFolder
End If
End If
fileName = Dir
Wend
If missingFolders = "" Then
MsgBox "All subfolders exist. All files moved to their respective destination folder"
Else
MsgBox "The following subfolders don't exist:" & vbCrLf & _
missingFolders
End If
End Sub
After it identifies all that fit within that manager's name, I want to group only those manager's employee files into a folder with their name up until the first _.
If the file extension is .xlsx, then change fileName = Dir(sourceFolder & "*.xls") to fileName = Dir(sourceFolder & "*.xlsx").
Consider the InStr function, which "returns a Variant (Long) specifying the position of the first occurrence of one string within another."
As is, destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1) finds everything to the left of the last period.
So if you want to the destination folder to be Manager Name, then perhaps destinationFolder = Left$(fileName, InStr(fileName, "_") - 1)
Note that this can be made more robust to handle the possibility of no _ in the file name, or the file name beginning with _, with an initial If InStr(fileName, "_") > 1).