I have a series of excel spreadsheets that need to change their filename and save to an alternate path.I have run into a wall trying to attempt this on my own.
The original filename: A0001_lp_profile.csv (the A000# will not always be A0001)
The new filename: A0001.RecentlyOpenedFiles.LNK.xlsx
The first five characters will not change during the rename.
The original path: E:\Backup\VSNMM-01691\Cases\VSNMM-01691.A0001\Exports_fileFolderOpening
The new path: E:\Backup\VSNMM-01691\Reports
VSNMM-01691 will not always be in the path and changes quite often to something in a similar format. The "E:\Backup\" will always be the beginning of the path.
This should work, just make sure that i got your paths and filename patterns right:
Dim file As Variant
Dim wb As Workbook
Dim originalpath As String, newpath As String
originalpath = "E:\Backup\VSNMM-01691\Cases\VSNMM-01691.A0001\Exports_fileFolderOpening\"
newpath = "E:\Backup\VSNMM-01691\Reports\"
file = Dir(originalpath)
'loop through files in original folder
While (file <> "")
'match filename with pattern (# means one number, so 4 single numbers) change this if i did it wrong
If file Like "A####_lp_profile.csv" Then
'open the csv file
Set wb = Workbooks.Open(originalpath & file)
'save in new path as xlsx (without the Fileformat, the file will be unreadable
wb.SaveAs newpath & Left(file, 5) & ".RecentlyOpenedFiles.LNK.xlsx", ThisWorkbook.FileFormat
'close workbook in original path, discard changes
wb.Close False
'clear variable
Set wb = Nothing
End If
'next file
file = Dir
Wend
Related
I frequently run a macro on folders that contain .doc and .docx files. Currently, my macro is only able to edit one type of file and then I have to change my macro from .doc to .docx (or vice versa) and run again.
How could I get both file types in one go?
The current code.
'UpdateDocuments
Sub UpdateDocuments()
Dim file
Dim path As String
'Path to your folder.
'make sure to include the terminating "\"
‘Enter path.
path = "C:\Users\emckenzie\Documents\TEMP PLOT\macro practice\Andria footer change\"
'Change this file extension to the file you are opening
file = Dir(path & "*.docx")
Do While file <> ""
Documents.Open FileName:=path & file
'This is the call to the macro you want to run on each file the folder
'Enter macro.
Call Permit2hundred
' Saves the file
ActiveDocument.Save
ActiveDocument.Close
'set file to next in Dir
file = Dir()
Loop
End Sub
To answer your question:
Use a wildcard like * or ? in this line: fileExtension = "*.doc?"
You can read more about wildcard characters here
Some suggestions on your code:
Assign variable types when you're defining them
Indent your code (You can use www.rubberduckvba.com)
Define your variables close to where you first use them (matter of preference)
When working with documents, assign them to a document variable and refer to that variable instead of ActiveDocument
Use basic error handling
Additional tip:
When calling this procedure Permit2hundred you could pass the targetDocument variable like this:
'This is the call to the macro you want to run on each file the folder
'Enter macro.
Permit2hundred targetDocument
' Saves the file
targetDocument.Save
And the definition of that procedure could be something like this:
Private Sub Permit2hundred(ByVal targetDocument as Document)
'Do something
End Sub
This is the refactored code:
Public Sub UpdateDocuments()
' Add basic Error handling
On Error GoTo CleanFail
'Path to your folder.
'make sure to include the terminating "\"
'Enter path.
Dim folderPath As String
folderPath = "C:\Users\emckenzie\Documents\TEMP PLOT\macro practice\Andria footer change\"
'Change this file extension to the file you are opening
Dim fileExtension As String
fileExtension = "*.doc?"
' Get files in folder
Dim fileName As String
fileName = Dir(folderPath & fileExtension)
' Loop through files in folder
Do While file <> vbNullString
Dim targetDocument As Document
Set targetDocument = Documents.Open(fileName:=folderPath & file)
'This is the call to the macro you want to run on each file the folder
'Enter macro.
Permit2hundred
' Saves the file
targetDocument.Save
targetDocument.Close
'set file to next in Dir
file = Dir()
Loop
CleanExit:
Exit Sub
CleanFail:
MsgBox "Something went wrong. Error: " & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I prefer to display a file picker dialog and then select what I want. I am then able to choose a doc or docx file without having to alter my code. The Filter property determines the file types allowed. Note that this code clears the filter when it ends, otherwise that is the filter Word will use from that point on, even for manually initiated (non-programmatic) requests of File Open.
This example is setup to allow multiple selections. You can change the AllowMultiSelect to False and then the code will run with only one file at a time.
Dim i As Integer, selFiles() As String
Dim strFolderPath As String, Sep As String
Sep = Application.PathSeparator
Erase selFiles
'Windows Office 2019, 2016, 2013, 2010, 2007
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the files to update"
.InitialFileName = curDir
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "All Word Files", "*.docx; *.docm; *.doc", 1
If .Show = 0 Then
Exit Sub
End If
ReDim Preserve selFiles(.SelectedItems.Count - 1)
strFolderPath = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Sep))
For i = 0 To .SelectedItems.Count - 1
selFiles(i) = .SelectedItems(i + 1)
Next
.Filters.Clear
End With
It seems like I just cant add a copied Part two a productDoc. Its possible to paste it directly into the ProductDocument, but than I cant save it. What I need to do is:
Create ProductDoc
Create a ProductDoc in rootProductDoc
Copy Part from another Doc
Paste Part in ProductDoc from second step
Anyone an idea how to do that?
Im using CATIA V5-6 Release 2016, ServicePack 5 Build Number 26
There just dont seem any functions to select the ProductDoc from step 2.
I figured it out, thanks downvoters.
You cannot add a PartDocument itself to a Product, it needs to be a ProductDocument to which a Part is added (with AddNewComponent("Part","")).
Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim productDoc As ProductDocument
Set productDoc = documents1.Add("Product")
Dim rootProduct As Product
Set rootProduct = productDoc.Product
Dim childProduct As Product
Set childProduct = rootProduct.Products.AddNewComponent("Product", "")
Dim part1 As Product
Set part1 = childProduct.Products.AddNewComponent("Part", "")
Dim part2 As Product
Set part2 = childProduct.Products.AddNewComponent("Part", "")
MaxVR, thanks for coming back and posting the solution! It was really helpful for the product symmetry macro I'm working on. There's another way to insert parts into a CATProduct if the parts already exist.
'These three lines are variants
'products_variant_file_open represents the product that we want our part to be added to
'variant_array_file_open is where we store our file path
Dim products_variant_file_open
Set products_variant_file_open = current_rh_product.Products
Dim variant_array_file_open(0)
variant_array_file_open(0) = root_file_location & "\" & current_product.PartNumber & "_RH.CATPart"
'Below is the command that inserts the CATPart. The left thing to specify is the array that holds
'the file name and the right thing is the type of file to add
Here's some sample code that shows how I got my file path to insert parts from
'prod_doc.Path gets path of the product document and the stuff to the right becomes the folder name
root_file_location = prod_doc.Path & "\" & name_prod.Name & "_RH_Parts"
Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Creates a folder in specified path with the specified name
fso.CreateFolder (root_file_location)
Then I used a function to loop through the folder and search for specific names
Function rh_folder_lookup(rh_part_file_name As String,
root_file_location_func As String)
'Default rh folder lookup to be false when it's false we can't find a matching file in our folder so we make a new rh part
rh_folder_lookup = False
'Set the file name to all the files in our folder
Dim fileName As Variant
fileName = Dir(root_file_location_func & "\") 'The slash at the ends makes the directory all the files in the folder instead of just that folder
'Loop through all files in a folder
While fileName <> ""
If fileName = rh_part_file_name & ".CATPart" Or fileName = rh_part_file_name Then
'MsgBox fileName & "!!!"
rh_folder_lookup = True
Exit Function
End If
fileName = Dir 'Set the fileName to the next file
Wend 'Wend means end when the condition is true
End Function
I’ve made a simply macro to change names of files in a directory. At first it seemed correct, but then I’ve noticed something strange. For instance there is 48 files in a directory and initially the macro numbers files properly – “1”, “2”, “3” and so forth (in Immediate window the variable “i” changes from 1 to 49), but if I run the macro several times, sometimes the variable “i” changes from 1 to 148 and a first number of files starts from 100: “100”, “101”, “102” et cetera. Then I run the macro again and it counts files properly, then – again – an error mentioned above occurs … and so on. I don’t see any rule in it. Any help is greatly appreciated.
Sub nameChange()
Dim source As FileSystemObject
Dim fold As folder
Dim fObj As File
Dim path As String, newName As String, number As String, ext As String
Dim i As Long
On Error GoTo closeSub
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End With
Set source = New FileSystemObject
Set fold = source.GetFolder(path)
i = 1
newName = InputBox("New name")
For Each fObj In fold.Files
ext = Mid(fObj.Name, (InStrRev(fObj.Name, ".")))
Name fObj As path & "\" & newName & i & ext
i = i + 1
Next fObj
closeSub:
Exit Sub
End Sub
I couldn't find an existing thread fitting my problem and now I'm stuck and searching for help ;)
What I want to accomplish: Several .xlsx tables filled with content are in the same folder, I want to pick the same two cells' content out of every file and save it to a newly created .xslx file named "Summary.xlsx".
My makro reads out the cells' content properly and also saves the Summary.xlsx. However it looks like the file is corrupted because when I try to open it Excel would show me just a blank page (not even a sheet).
Watching the file using breakpoints, the headlines get written properly: However the table in Summary.xlsx starts to disappear right when I try to write the content of the other files in the do-while-loop.
Additional info: I start the makro from an extra makro-file in the same directory as the other files using the play button in the module.
Here's my code.
Warning: I'm new to VBA, obviously :)
Sub MergeMakro()
Dim directory As String, fileName As String, otherWorkbook As Workbook, sumFileName As String, sumFilePath As String, i As Integer
thisFileName = "MergeMakro.xlsm"
sumFileName = "Summary.xlsx"
sumFilePath = ThisWorkbook.Path & "\" & sumFileName
' If sum file already exists, delete it
If Dir(sumFilePath) <> "" Then
Kill (sumFilePath)
End If
' create new sum file
Set sumWorkbook = Workbooks.Add
ActiveWorkbook.SaveAs fileName:=sumFilePath
Set sumSheet = sumWorkbook.ActiveSheet
' search in the file's directory
directory = "R:\ExcelStuff\Auswertungen\"
' headlines -> are written properly
sumSheet.Range("A1") = "Materialnummern"
sumSheet.Range("B1") = "Bezeichnung"
sumSheet.Range("C1") = "Gesamtkosten"
' start at line 2
i = 2
fileName = Dir(directory & "*.xls")
Do While fileName <> ""
If fileName <> thisFileName And fileName <> sumFileName Then
Set otherWorkbook = Workbooks.Open(directory & fileName)
' do not show windows
If Not (ActiveWorkbook Is Nothing) Then
ActiveWindow.Visible = False
End If
' remove last 5 chars of string (.xlsx)
fileName = Left(fileName, Len(fileName) - 5)
' do not try to open the makro-file itself
Set otherSheet = otherWorkbook.Sheets(fileName)
' write data into file -> here the file starts to get corrupted
sumSheet.Range("A" & i) = fileName
sumSheet.Range("B" & i) = otherSheet.Range("C4")
sumSheet.Range("C" & i) = otherSheet.Range("G4")
i = i + 1
otherWorkbook.Close
End If
' get the next file
fileName = Dir()
Loop
Workbooks(sumFileName).Save
Workbooks(sumFileName).Close
End Sub
Thanks in advance!
This seems so simple and I've had it working multiple times, but something keeps breaking between my Dir call (to iterate through a directory) and opening the current file. Here's the pertinent code:
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceCurrentFile)
What I get with this is a file access error as the Application.Workbooks.Open is trying to open "C:\ExcelWIP\TestSource\\FILENAME" (note extra slash)
However when I take the final slash out of SourceLoc, the results of Dir(SourceLoc) are "" (it doesn't search the directory).
The frustrating thing is that as I've edited the sub in other ways, the functionality of this code has come and gone. I've had it work as-is, and I've had taking the '/' out of the directory path make it work, and at the moment, I just can't get these to work right together.
I've scoured online help and ms articles but nothing seems to point to a reason why this would keep going up and down (without being edited except for when it stops working) and why the format of the directory path will sometimes work with the final '/' and sometimes without.
any ideas?
This would open all .xlxs files in that directory son.
Sub OpenFiles()
Dim SourceCurrentFile As String
Dim FileExtension as String: FileExtension = "*.xlxs"
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
SourceCurrentFile = Dir()
'Start looping through directory
Do While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc &"\"& SourceCurrentFile)
SourceCurrentFile = Dir(FileExtension)
Loop
End Sub
JLILI Aman hit on the answer which was to take the results of Dir() as a string. Using that combined with the path on Application.Open allows for stable behaviors from the code.
New Code:
Dim SourceLoc as String
Dim SourceCurrentFile as String
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc & "/" & SourceCurrentFile)
I didn't include the recommended file extension because I'm dealing with xls, xlsx, and xlsm files all in one directory. This code opens all of them.
Warning - this code will set current file to each file in the directory including non-excel files. In my case, I'm only dealing with excel files so that's not a problem.
As to why this happens, it does not appear that Application.Open will accept the full object results of Dir(), so the return of Dir() needs to be a String. I didn't dig deeper into the why of it beyond that.
Consider using VBA's FileSystemObject which includes the folder and file property:
Sub xlFilesOpen()
Dim strPath As String
Dim objFSO As Object, objFolder As Object, xlFile As Object
strPath = "C:\ExcelWIP\TestSource"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
For Each xlFile In objFolder.Files
If Right(xlFile, 4) = "xlsx" Or Right(xlFile, 3) = "xls" Then
Application.Workbooks.Open (xlFile)
End If
Next xlFile
Set objFSO = Nothing
Set objFolder = Nothing
End Sub