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!
Related
I am getting an error when using MoveFile trying to move a ppt file in place of a pptx file, but not the other way around. In this sample code I am moving a file from files_temp folder to a files folder (folder creation code not included).
Set theForm = Server.CreateObject("ABCUpload4.XForm")
theForm.MaxUploadSize = 5242880
theForm.Overwrite = True
Set theField = theForm.Files("filefield")
f_name = Trim(UCase(theField.FileName))
f_type = Trim(UCase(theField.FileType))
'=================================================================
' Overwrite ppt/pptx file if exists else move from temp to save folder
'=================================================================
Dim file_type_array1 = Array("pptx", "ppt")
Dim file_type_exists1 = false
temp_file_path = Trim(Request.ServerVariables("APPL_PHYSICAL_PATH")) & "files_temp\" & f_name & "." & f_type
save_file_path = Trim(Request.ServerVariables("APPL_PHYSICAL_PATH")) & "files\" & "new_file_name." & f_type
'save_file_path w/o extension (used to loop through all extensions)
save_file_path_ne = Trim(Request.ServerVariables("APPL_PHYSICAL_PATH")) & "files\" & "new_file_name."
Set fsobject = Server.CreateObject("Scripting.FileSystemObject")
For x = 0 To UBound(file_type_array1)
If fsobject.FileExists(save_file_path_ne & file_type_array1(x)) then
fsobject.DeleteFile(save_file_path_ne & file_type_array1(x))
fsobject.MoveFile temp_file_path, save_file_path
file_type_exists1 = true
End If
Next
If file_type_exists1 = false Then
fsobject.MoveFile temp_file_path, save_file_path
End If
set fsobject = nothing
file_type_exists1 = false
Cases when this code works:
1st upload of a file (pptx OR ppt) - properly moved from "files_temp" to "files" folder
ppt file is overwritten by pptx file - ppt file is properly deleted and pptx file is moved from "files_temp" to "files" folder
Case when this code does NOT work:
pptx file is attempted to be overwritten by ppt file - pptx file is properly deleted and a file is taken from "files_temp" folder then Error on the MoveFile function:
Microsoft VBScript runtime error '800a0035'
File not found
I have not included all the code, but should be enough to solve this problem. Let me know if you need additional code provided. Also rewritten my existing code for this example, so there's a small chance of Syntax Errors.
I did not figure out the exact reason why I was having these issues, but I do have a workaround. Instead of using MoveFile to move and simultaneously rename the temp file, I had to break it down into two steps. I had to first copy the file using CopyFile from temp_file_path to save_file_path then change the file name inside the save_file_path.
Revised Code:
'save_file_path but with original file name
save_file_path_o = Trim(Request.ServerVariables("APPL_PHYSICAL_PATH")) & "files\" & f_name & "." & f_type
Set fsobject = Server.CreateObject("Scripting.FileSystemObject")
For x = 0 To UBound(file_type_array1)
If fsobject.FileExists(save_file_path_ne & file_type_array1(x)) then
fsobject.DeleteFile(save_file_path_ne & file_type_array1(x))
fsobject.CopyFile temp_file_path, save_file_path_o
Set objFile = fsobject.GetFile(save_file_path_o)
objFile.Name = save_file_name
file_type_exists1 = true
End If
Next
If file_type_exists1 = false Then
fsobject.MoveFile temp_file_path, save_file_path
End If
set fsobject = nothing
set objFile = nothing
file_type_exists1 = false
I would like to simulate a folder copy exactly how it would happen if a user copy/pasted it in Windows Explorer (keep all the file/directory attributes, copy all subfolders and files in the same structure, etc.), and be able to update a progress bar during the copy.
FileSystem.Copy is a wonderful function that would mimic a user copy/paste, but I am unable to update a progress bar during the copy using that function.
The only way I have found to be able to achieve this is to write a custom function, so the ProgressBar.Maximum can be set to the size of the Folder and the ProgressBar.Value is updated after each individual file copy.
This function is becoming a lot of code to achieve something that seems simple. I also cannot disregard the notion that since this is customized that I am doing something wrong that I just don't know to test for. For example, had the folder I was testing with not had empty subfolders and hidden folders, I never would have adjusted for those things.
So I have to wonder if I am overlooking something much simpler to achieve this same goal.
My code is as follows:
Private Sub CopyFolderWithProgress(folderToCopy As String, newFolder As String, progBar As ProgressBar)
'Validate folder to copy
If Directory.Exists(folderToCopy) Then
If folderToCopy.Substring(folderToCopy.Length - 1) <> "\" Then
folderToCopy &= "\"
End If
Else
MsgBox("Invalid directory given: " & folderToCopy)
End
End If
'Validate new folder
If Directory.Exists(newFolder) Then
If newFolder.Substring(newFolder.Length - 1) <> "\" Then
newFolder &= "\"
End If
Else
MsgBox("Invalid directory given: " & newFolder)
End
End If
'Create folderToCopy as a new subfolder of newFolder
newFolder &= New DirectoryInfo(folderToCopy).Name & "\"
Dim di As DirectoryInfo
di = Directory.CreateDirectory(newFolder)
di.Attributes = New DirectoryInfo(folderToCopy).Attributes
'Create all subfolders
For Each thisDir In Directory.GetDirectories(folderToCopy, "*", SearchOption.AllDirectories)
Dim thisDirRelative = thisDir.Remove(0, Len(folderToCopy))
di = Directory.CreateDirectory(newFolder & thisDirRelative)
di.Attributes = New DirectoryInfo(thisDir).Attributes
Next
'Determine size of all files for progress bar
Dim dirSize As Long
For Each curFile In Directory.GetFiles(folderToCopy, "*", SearchOption.AllDirectories)
dirSize += FileLen(curFile)
Next
'Set progress bar 100% to size of all files
progBar.Value = 0
progBar.Maximum = dirSize
'Copy all files into correct folder and update progress bar
For Each curFile In Directory.GetFiles(folderToCopy, "*", SearchOption.AllDirectories)
'Get name of file
Dim curFileName = Path.GetFileName(curFile)
'Determine if file is in a subfolder of fileTopCopy
Dim curFileDir = Path.GetDirectoryName(curFile) + "\"
Dim curFileSubfolders = curFile.Substring(0, curFile.IndexOf(curFileName)).Replace(folderToCopy, "")
'Copy file
If File.Exists(curFile) Then
File.Copy(curFile, newFolder & curFileSubfolders & curFileName)
Else
Console.Write("Issue copying a file that should exist in source folder: " & curFile)
End If
'Update Progress Bar
progBar.Value += FileLen(curFile)
Next
End Sub
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
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
I have an application that exports daily reports in txt format.
I have a macro that extracts certain lines of data from those reports and puts them in an output xls file. my macro's input directory is curently a separate folder that i manually move today's reports into.
I'd like for my macro to be able to just read from the default report folder and only read files created with today's date.
the naming convention of the report files is as follows:
1101_16_16_AppServiceUser_YYYYMMDDhhmmssXXX.txt
not sure what the last 3 digits on the file name represents, but they're always numbers.
Help?
WOW that was fast! thanks... fist time using stackoverflow.
I guess i should include the code that pulls data and dumps it to excel... here it is:
Sub PullLinesFromEPremisReport()
Dim FileName, PathN, InputLn As String
Dim SearchFor1, SearchFor2, OutpFile As String
Dim StringLen1, StringLen2 As Integer
Dim colFiles As New Collection
Dim bridgekey As String
PathO = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\output\"
PathN = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\input\"
FileName = Dir(PathN)
While FileName <> ""
colFiles.Add (FileName)
FileName = Dir
Wend
SearchFor1 = "BRIDGE KEY"
StringLen1 = Len(SearchFor1)
OutpFile = "RESULTS.xls"
Open PathO & OutpFile For Output As #2
For Each Item In colFiles
Open PathN & Item For Input As #1
Do Until EOF(1) = True
Line Input #1, InputLn
If (Left(LTrim$(InputLn), StringLen1) = SearchFor1) Then
bridgekey = InputLn
End If
Loop
Close #1
Next Item
Close #2
End Sub
Daniel's answer is correct, but using the FileSystemObject requires a couple of steps:
Make sure you have a reference to "Microsoft Scripting Runtime":
Then, to iterate through the files in the directory:
Sub WorkOnTodaysReports()
'the vars you'll need
Dim fso As New FileSystemObject
Dim fldr As Folder
Dim fls As Files
Dim fl As File
Set fldr = fso.GetFolder("C:\Reports")
Set fls = fldr.Files
For Each fl In fls
'InStr returns the position of the substring, or 0 if not found
' EDIT: you can explicitly use the reliable parts of your file name
' to avoid false positives
If InStr(1, fl.Name, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
'Do your processing
End If
Next fl
End Sub
EDIT: So I think, from the code you posted, you could send PathN to the main Reports folder like you desire, then just modify your While statement like so:
While FileName <> ""
If InStr(1, FileName, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
colFiles.Add (FileName)
End If
FileName = Dir
Wend
Two ways you can do this off the top of my head. Assuming you are using a File via the FileSystemObject.
Do an Instr on the file.Name looking for Format(Date, "YYYYMMDD") within the string.
Or use a far simpler approach loop through the files and within your loop do this:
If File.DateCreate >= Date Then
'Do something
end if
Where File is the actual variable used to for looping through the files.
If fileName like "*AppServiceUser_" & Format(Now, "YYYYMMDD") & _
"#########.txt" Then
'good to go
End If