Looking help - a way to pull the string from the filename and perform a task using the string part of the formula manually.
Right now I can pull the file from the folder and use the string part of my program
C:\ XXXX_555_GGGGG.xlsx ( extraxt '555")
C:\ XXXX_101_GGGGG.xlsx (extraxt"101")
....cont!
manually we can do this for each of the files:
Sub Combined()
wb.Sheets("Sheet1").Range("b2").Value = _
Application.SumIfs(Sheet1.Columns(2), Sheet1.Columns(1), "555")
End Sub
Sub Combined1()
wb.Sheets("Sheet1").Range("b3").Value = _
Application.SumIfs(Sheet1.Columns(2), Sheet1.Columns(1), "101")
End Sub
Looking for a better way to automated this:
Open the folder
pull the string from filename path ( file one) ( i.e '555')
use the string part of my sum formula
next file
Thanks in advance
You can use Dir() to loop over files in a folder
Sub tester()
Dim c As Range, f, arr, wb As Workbook
Set wb = ThisWorkbook 'or whatever
Set c = wb.Sheets("Sheet1").Range("B2")
f = Dir("C:\FolderTest\*.xlsx")
Do While Len(f) > 0
arr = Split(f, "_")
If UBound(arr) = 2 Then 'check file pattern
c.Value = Application.SumIfs(Sheet1.Columns(2), Sheet1.Columns(1), arr(1))
Set c = c.Offset(1, 0)
End If
f = Dir()
Loop
End Sub
Related
I am trying to loop through all subfolders within a folder, compiling all the names of the files. I'm having a bit of trouble though as I have adapted this code from a macro that only loops through one folder and compiles file names. Thank you greatly for your time!
Sub FindFiles()
Cells(1, 1).Select
Dim F As String
Dim G As String
F = Dir("C:\Users\z003nttv\Desktop\Folder\" & "*")
Do While Len(F) > 0
Do While Len(G) > 0
G = Dir(F & "*.*")
ActiveCell.Formula = G
ActiveCell.Offset(1, 0).Select
G = Dir()
Loop
F = Dir()
Loop
End Sub
Found the answer at the following site:
https://www.extendoffice.com/documents/excel/2994-excel-list-all-files-in-folder-and-subfolders.html
Hope it may lend some help..very user friendly!
I was working on this code before you posted the link and had second thoughts posting my work. So I checked out the link you posted. I believe that the code I wanted to post is succinct & addresses the point far better. Hence here you go
Step 1. The Reference
Step2. The Code.
Sub FindFiles()
Dim fso As FileSystemObject
Dim Folder As Folder
Dim Files As Files
Dim path, s As String
'' Input Path : Please change as needed
path = Sheets("Sheet1").Cells(1, 2).Value
Set fso = New FileSystemObject
Set Basefolder = fso.GetFolder(path)
Set SubFolders = Basefolder.SubFolders
Dim i As Integer
i = 1
For Each Folder In SubFolders
Set Files = Folder.Files
For Each File In Files
With Sheets("Sheet1")
.Cells(i, 1).Value = Folder
.Cells(i, 2).Value = File
i = i + 1
Next File
Next Folder
End Sub
Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:
I've looked and found a little help so far but I'm stuggling with the for each logic for this Excel Macro I'm trying to make.
Basically I have 4 columns of data. Column A has the name of something and column D has either TRUE or FALSE.
I would like a macro wired to a button that creates a new text file in a given directory named after the content of Col A but only if Col D in that row is labled as "TRUE".
For example if I have the following.
ColA = Test ColD = TRUE
ColA = Test2 ColD = FALSE
ColA = Test3 ColD = TRUE
I will get 2 text files anmed Test.txt and Test3.txt.
I know I need a for each loop to look through the range of a1-d(whatever number) and then when D = True do a SaveAs I guess??
This is the code I have so far (yes I know it's very incomplete but this is as far as my logic got before hitting a wall).
Dim fileName As String
Dim filePath As String
Dim curCell As Object
Dim hideRange As Range
filePath = "C:\ExcelTest\"
hideRange = Range("D1:D1048576")
fileName = *Content of Cell A from this Row*
For Each Row In Range("A1:D1048576")
IF curCell.value In Range hideRange = "TRUE"
Then curCell.SaveAs fileName & ".txt, xlTextWindows
Any help or even pointing me in the right direction would be great. I searched around a bit for some examples and couldn't find anything that really matched what I wanted to do.
You are pretty close, but you are looping one hell of a lot of cells there.
Here is the code to loop the rows, this stops at the last populated cell in the column.
Sub LoopRows()
dim sht as worksheet
set sht = Thisworkbook.Sheets("Name of Worksheet")
'loop from row 1 to the last row containing data
For i = 1 To sht.Range("A:A").End(xlDown).Row
'check the value in column 4 for this row (i)
If sht.Cells(i, 4).Text = "TRUE" Then
CreateFile sht.Cells(i, 1).Value
End If
Next i
End Sub
For writing the file, to keep it simple it would reference Microsoft scripting runtime and do it as follows:
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\" & FileName & ".txt", True
End Sub
EDIT
I can't see why you aren't getting a file created, my tests work fine for me on a windows machine.
Can you please try the following code alone in a button and see if it opens a text file?
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\testfso.txt"
Shell "C:\WINDOWS\notepad.exe c:\temp\testfso.txt", vbMaximizedFocus
EDIT 2
Try this, and see if it opens the text file..
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
Dim fName as String
fName = "c:\temp\" & FileName & ".txt"
fso.CreateTextFile fName, True
Shell "C:\WINDOWS\notepad.exe " & fName, vbMaximizedFocus
End Sub
What you are looking for is something like this:
Sub test()
Dim filePath As String
filePath = "C:\ExcelTest\"
Dim xRow As Variant
For Each xRow In Range("A1:D100").Rows
If xRow(1, 4).Value = "TRUE" Then
Open filePath & xRow(1, 1) & ".txt" For Output As #1
Write #1, xRow(1, 2), xRow(1, 3)
Close #1
End If
Next
End Sub
While it works without errors, I would not use it as it is right now.
If you have any questions, just ask.
EDIT
I've run some tests and noticed windows prevents me to create files inside specific folders... pls try this as a new sub and run it:
Sub testForText()
Open Environ("AppData") & "\Testing.txt" For Output As #1
Write #1, "dada"
Close #1
Shell "notepad.exe " & Environ("AppData") & "\Testing.txt", vbNormalFocus
End Sub
Then tell me if notepad opens up with "Testing.txt"
As we know, we use Find() method to find whether a string or any Microsoft Excel data type exists in an excel.
(Usually we do it on set of data)
I want to know if any such method available when we loop through folder(of files) using Dir function.
Situation:
I have an excel - 'FileNames.xlsx' in which 'Sheet1' has names of files having extensions .pdf/.jpg/.jpeg/.xls/.xlsx/.png./.txt/.docx/ .rtf in column A.
I have a folder named 'Folder' which has most(or all) of the files from 'FileNames.xlsx'.
I have to check whether all the file-names mentioned in the 'FileNames.xlsx' exist in 'Folder'.
For this I have written the below VBScript(.vbs):
strMessage =Inputbox("Enter No. of Files in Folder","Input Required")
set xlinput = createobject("excel.application")
set wb123 =xlinput.workbooks.Open("E:\FileNames.xlsx")
set sh1 =wb123.worksheets("Sheet1")
For i = 2 to strMessage +1
namei = sh1.cells(i,1).value
yesi = "E:\Folder"+ namei +
If namei <> yesi Then
sh1.cells(i,1).Interior.Color = vbRed
Else
End If
Next
msgbox "Success"
xlinput.quit
As I wasn't able to get the required Output I tried it recording a small Excel VBA Macro. (Changed FileNames.xlsx to FileNames.xlsm)
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2A:" & lastRow)
MyFile = Dir(MyFolder & "\*.xlsx")
'Here I actually need to pass all file extensions to Dir
Do While MyFile <> ""
If filename = MyFile Then
'Do Nothing
Else
filename.Interior.Color = vbRed
MyFile = Dir
Next
End Sub
The above is a failed attempt.
I thought of trying it with method similar to Find()
Sub LoopThroughFiles()
Dim lastRow As Long
'Dim LastFile As Long
'Is there need of it (LastFile variable)? I kept this variable
'to save (prior known) count of files in folder.
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
'LastFile = 'Pass count of Files in folder to this variable.
Dim fileName As Range
For Each fileName In Worksheets("Sheet1").Range("A2:A" & lastRow)
Dim rngFnder As Range
On Error Resume Next
'Error at below line.
Set rngFnder = Dir("E:\Folder\").Find(filename)
'This line gives me error 'Invalid Qualifier'
'I am trying to use method similar to Find()
If rngFnder Is Nothing Then
filename.Interior.Color = vbRed
End If
Next
End Sub
But, I couldn't achieve the result. Can anyone tell me is there any such function available to 'Find' whether all filenames in an excel exist in a folder after looping through folder using Dir?
As per my knowledge, Dir function works with only one file extension at a time.
Is it possible to use Dir function for multiple file extensions at a time?
Expected Output:
Assume I have 8 filenames in 'FileNames(.xlsx/.xlsm)'. Out of which Arabella.pdf and Clover.png are not found in 'Folder', Then I want to color cells for these filenames in red background in excel as in below image.
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2:A" & lastRow)
MyFile = MyFolder & "\" & filename
If Not FileExists(MyFile) Then
filename.Interior.Color = vbRed
End If
Next
End Sub
Public Function FileExists(strFullpathName As String) As Boolean
If Dir(strFullpathName) <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
You can output a list of the files that are contained in the folder. I found a really helpful tutorial on that here: http://software-solutions-online.com/2014/03/05/list-files-and-folders-in-a-directory/#Jump1
If you then loop through both the original and the output lists and look for a match. Easiest is to first colour them all red, and un-colour the matches. Else you would need an additional if-statement that states: When you reach the last element in the original list, and no match has been found, then colour red.
Edit: For continuity's sake I copied the code bits of the link I mentioned above:
Getting all file names form within 1 folder:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:StuffFreelancesWebsiteBlogArraysPics")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
This is what I want to achieve:
I want to copy the contents of the entire first sheet in the most recently modified excel file in a specified directory. I then want to paste the values of this copy operation to the first sheet of the current workbook.
I am aware there are macros to get the last modified file in a directory but I am unsure of a quick and clean way to implement this.
See below. This will use the current active workbook and look in C:\Your\Path for the Excel file with the latest modify date. It will then open the file and copy contents from the first sheet and paste them in your original workbook (on the first sheet):
Dim fso, fol, fil
Dim wkbSource As Workbook, wkbData As Workbook
Dim fileData As Date
Dim fileName As String, strExtension As String
Set wkbSource = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder("C:\Your\Path")
fileData = DateSerial(1900, 1, 1)
For Each fil In fol.Files
strExtension = fso.GetExtensionName(fil.Path)
If Left$(strExtension, 3) = "xls" Then
If (fil.DateLastModified > fileData) Then
fileData = fil.DateLastModified
fileName = fil.Path
End If
End If
Next fil
Set wkbData = Workbooks.Open(fileName, , True)
wkbData.Sheets(1).Cells.Copy
wkbSource.Sheets(1).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
wkbData.Close
Set fso = Nothing
Set fol = Nothing
Set flc = Nothing
Set wkbData = Nothing
I had nothing better to do on my lunch - so here goes.
To fire it use: getSheetFromA()
Put this in the current file:
Dim most_recent_file(1, 2) As Variant
Sub getSheetFromA()
' STEP 1 - Delete first sheet in this workbook
' STEP 2 - Look through the folder and get the most recently modified file path
' STEP 3 - Copy the first sheet from that file to the start of this file
' STEP 1
' Delete the first sheet in the current file (named incase if deleting the wrong one..)
delete_worksheet ("Sheet1")
' STEP 2
' Now look for the most recent file
Dim folder As String
folder = "C:\Documents and Settings\Chris\Desktop\foldername\"
Call recurse_files(folder, "xls")
' STEP 3
Dim most_recently_modified_sheet As String
most_recently_modified_sheet = most_recent_file(1, 0)
getSheet most_recently_modified_sheet, 1
End Sub
Sub getSheet(filename As String, sheetNr As Integer)
' Copy a sheet from an external sheet to this workbook and put it first in the workbook.
Dim srcWorkbook As Workbook
Set srcWorkbook = Application.Workbooks.Open(filename)
srcWorkbook.Worksheets(sheetNr).Copy before:=ThisWorkbook.Sheets(1)
srcWorkbook.Close
Set srcWorkbook = Nothing
End Sub
Sub delete_worksheet(sheet_name)
' Delete a sheet (turn alerting off and on again to avoid prompts)
Application.DisplayAlerts = False
Sheets(sheet_name).Delete
Application.DisplayAlerts = True
End Sub
Function recurse_files(working_directory, file_extension)
With Application.FileSearch
.LookIn = working_directory
.SearchSubFolders = True
.filename = "*." & file_extension
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
number_of_files = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
vFile = .FoundFiles(i)
Dim temp_filename As String
temp_filename = vFile
' the next bit works by seeing if the current file is newer than the one in the array, if it is, then replace the current file in the array.
If (most_recent_file(1, 1) <> "") Then
If (FileLastModified(temp_filename) > most_recent_file(1, 1)) Then
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Else
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Next i
Else
MsgBox "There were no files found."
End If
End With
End Function
Function FileLastModified(strFullFileName As String)
' Taken from: http://www.ozgrid.com/forum/showthread.php?t=27740
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
s = f.DateLastModified
FileLastModified = s
Set fs = Nothing: Set f = Nothing
End Function