I'm tying to stop the macro if a .txt file has been modified today (i.e. within the last 30s)s, below is my code but it gives an error 91 on the line file = ThisWorkbook.Path & "\Logs.txt\" whenever I try to run it. What am I missing? Thanks.
Sub Calculate()
Dim Fdate As Date
Dim FileInFromFolder As Object
Dim file As Object
file = ThisWorkbook.Path & "\Logs.txt\"
Set FSO = CreateObject("scripting.filesystemobject")
Fdate = file.Int(FileInFromFolder.DateLastModified)
If Fdate = Date Then GoTo eh
Else
'Minimize workbook
ActiveWindow.WindowState = xlMinimized
'Switch to manual calculation of formulae
Application.Calculation = xlManual
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Call Backup
Call Move
'Switch to automatic calculation of formulae
Application.Calculation = xlAutomatic
ActiveWorkbook.PrecisionAsDisplayed = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Done:
Exit Sub
eh:
' All errors will jump to here
MsgBox "error test"
End Sub
Edit: added error location.
First you are saying the variable file is of type Object
Dim file As Object
And then you assign a string to it
file = ThisWorkbook.Path & "\Logs.txt\"
Which is not valid.
I'm guessing you are trying to get a file object from the path.
You can do that using the FileSystemObject you created (but didn't use)
dim fileName as String
Dim file As Object
Dim FSO as Object
fileName = ThisWorkbook.Path & "\Logs.txt"
set FSO = CreateObject("scripting.filesystemobject")
set file = FSO.GetFile(fileName)
The problem is the trailing \ in file = ThisWorkbook.Path & "\Logs.txt\"
Related
I have a code that I found to loop through all of the files in the folder named Loop_AllWordFiles_inFolder and it calls whatever code you put in to execute some kind of action on the word documents in your selected folder. This code will run.
However I run into a problem when I try to have it call upon the code.. I don't know how to make them run together. The code it's calling is called ExtractSubject which is the action I need executed. I found this code online which runs through one file at a time and I'm trying to combine it with the looping files.
I'm new to VBA and I'm not sure how to fix the ExtractSubject code so they can run together. My end goal is to have two columns one with the title of the file and then beside it in the next cell the subject which I will be extracting. Something like this 1
Also I can't open a file without this read-only pop-up2 so if anyone knows how to fix that it would be appreciated but this is not my main concern atm.
Here's the two codes:
Option Explicit
Dim wb As Workbook
Dim path As String
Dim myFile As String
Dim myExtension As String
Dim myFolder As FileDialog
Dim wdApp As Object, wddoc As Object
Sub Loop_AllWordFiles_inFolder()
Set wdApp = CreateObject("Word.Application")
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With myFolder
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
path = .SelectedItems(1) & "\"
End With
' if the User select "Cancel"
NextCode:
path = path
If path = "" Then GoTo ResetSettings
' Target File Extension
myExtension = "*.doc"
' Target Path with Ending Extention
myFile = Dir(path & myExtension)
' Loop through all doc files in folder
Do While myFile <> ""
Set wddoc = wdApp.Documents.Open(fileName:=path & myFile)
' HERE you call your other routine
Call ExtractSubject
wddoc.Close SaveChanges:=False
myFile = Dir
Loop
Application.DisplayAlerts = PrevDispAlerts
MsgBox "Finished scanning all files in Folder " & path
ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set wdApp = Nothing
End Sub
Sub ExtractSubject()
Dim cDoc As Word.Document
Dim cRng As Word.Range
Dim i As Long
i = 2
Dim wordapp As Object
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open "c:\code practice\file1"
wdApp.Visible = True
Set wddoc = ActiveDocument
Set cRng = wddoc.Content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
.Execute
'Collapses a range or selection to the starting or ending position
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
Cells(i, 1) = cRng
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Execute
i = i + 1
End With
wordapp.Quit
Set wordapp = Nothing
End Sub
I think something like this should be close to what you're trying to do. Note you don't want all your variables as Globals - anything which needs to be shared between methods can be passed as an argument or returned as a function result.
Sub Loop_AllWordFiles_inFolder()
Const FILE_EXT As String = ".doc"
Dim wb As Workbook
Dim path As String
Dim myFile As String, theSubject As String
Dim wdApp As Object, wdDoc As Object
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show = -1 Then path = .SelectedItems(1) & "\"
End With
If Len(path) = 0 Then Exit Sub
'path = "C:\Temp\Test\" 'testing only
myFile = Dir(path & "*" & FILE_EXT) ' Target Path with Ending Extention
If Len(myFile) = 0 Then
MsgBox "No Word files found"
Exit Sub
End If
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Optimize '(don't really need this for this code though...)
Do While myFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=path & myFile)
theSubject = ExtractSubject(wdDoc) 'extract subject from wdDoc
wdDoc.Close SaveChanges:=False
If Len(theSubject) > 0 Then 'subject was found?
Name path & myFile As path & theSubject & FILE_EXT 'rename the file
Else
'output any problems
Debug.Print "Subject not found in '" & path & myFile & "'"
End If
myFile = Dir 'next file
Loop
wdApp.Quit 'no need to set to Nothing
Optimize False 'turn off speed enhancements
'Application.DisplayAlerts = PrevDispAlerts '?????
MsgBox "Finished scanning all files in Folder " & path
End Sub
'Return text between "SUBJECT:" and "JOB" in word document `wdDoc`
Function ExtractSubject(wdDoc As Word.document) As String
Dim cRng As Word.Range
Set cRng = wdDoc.content
With cRng.Find
.Forward = True
.Text = "SUBJECT:"
.Wrap = wdFindStop
If .Execute() Then
cRng.Collapse Word.WdCollapseDirection.wdCollapseEnd
cRng.MoveEndUntil Cset:="JOB"
ExtractSubject = Trim(cRng.Text)
End If
End With
End Function
'make changes to application settings to optimize macro speed in excel
Sub Optimize(Optional goFast As Boolean = True)
With Application
.ScreenUpdating = Not goFast
.EnableEvents = Not goFast
.Calculation = IIf(goFast, xlCalculationManual, xlCalculationAutomatic)
End With
End Sub
Try taking a look at this and see if it helps. From what I understand you are just trying to call one function in the middle of another.
From the first sentence of that link: "To call a Sub procedure from another procedure, type the name of the procedure and include values for any required arguments."
I have a folder with more than 300+ excel files and what I want to open each of the excel files inside the folder and run specific macro that's already stored in each of the excel files, save it, close it and move to the next file.
The macro which is stored in each excel file is connected to other macros inside the workbook, you could call it like a Main macro, so for example If I just tried to run the Main macro, without the macros it's connected, to all the files at the same time, it just wouldn't work, because it is connected to other macros. The code below is what I've done so far, but it doesn't work as intended
Sub run_mYearChange
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim wb As Workbook, ws As Worksheet
Dim wPath As String, wQuan As Long, n As Long
Dim fso As Object, folder As Object, subfolder As Object, wFile As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
Set fso = CreateObject("scripting.filesystemobject")
Set folder = fso.getfolder(wPath)
wQuan = folder.Files.Count
n = 1
For Each wFile In folder.Files
Application.StatusBar = "Processing folder : " & folder & ". File : " & n & " of : " & wQuan
If Right(wFile, 4) Like "*xlsm*" Then
Set wb = Workbooks.Open(wFile)
Application.Run "'C:\test2\*.xlsm*'!mYearChange.YearChangeFunction"
wb.Save True
wb.Close True
End If
n = n + 1
Next
Set fso = Nothing: Set folder = Nothing: Set wb = Nothing
MsgBox "End"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
I'm trying to find a solution everywhere and without luck. In this website there also hasn't been anything similar to what I'm asking. I would love all the help I could get, I'm kind of desperate, because nothing works.
Thank you for your help in advance.
You need to adjust the file name for each file opened.
Untested:
Sub run_mYearChange
'snipped....
Dim wPath As String, n As Long, f
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
if right(wPath, 1) <> "\" then wPath = wPath & "\"
f = Dir(wPath & "*.xlsm")
Do While Len(f) > 0
With Workbooks.Open(wPath & f)
Application.Run "'" & .Name & "'!mYearChange.YearChangeFunction"
.Close True 'save
End With
n = n + 1
f = Dir()
Loop
MsgBox "End"
'snipped...
End Sub
I am trying to set up a VBA macro to update link paths in excel. I looked up some code online and tried to put it together, and am getting errors. I am wondering if i could get some direction here. Please note that i am not a programmer by profession, just trying to reduce some manual updating work.
Cheers!
Private Sub CommandButton1_Click()
Dim FolderPath As String
Dim FSO As Object
Dim bookname As String
Dim wbook As Workbook
Dim oldname As String
Dim newname As String
oldname = "C:\Users\XX\Documents\[Broadstreet.xlsx]"
newname = "C:\Users\XX\Documents\[Broadstreet2.xlsx]"
FolderPath = "C:\Users\XX\Documents1"
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
End With
For Each Workbook In FSO.GetFolder(FolderPath).Files
bookname = Workbook.Name
MsgBox (bookname)
Set wb = Workbooks.Open(FolderPath & "\" & bookname)
ActiveWorkbook.ChangeLink oldname1, newname1, xlLinkTypeExcelLinks
wb.Close SaveChanges:=True
Next
Application.ScreenUpdating = True
End Sub
Workbooks in Folder Treatment
Loops through all Excel files (workbooks) in a folder, opens each one, changes a link from one document to another, saves the changes and closes the workbook.
xlLinkTypeExcelLinks is the default parameter of the Type
argument of the ChangeLink method and can therefore be omitted.
.Close True can be used in this way because SaveChanges is the
first argument of the Close method.
The Code
Private Sub CommandButton1_Click()
Const strOld As String = "C:\Users\XX\Documents\[Broadstreet.xlsx]"
Const strNew As String = "C:\Users\XX\Documents\[Broadstreet2.xlsx]"
Const strPath As String = "C:\Users\XX\Documents1"
Const strExt As String = "*.xls*"
Dim strName As String
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
End With
On Error GoTo ProcedureExit
strName = Dir(strPath & "\" & strExt)
Do While strName <> ""
With Workbooks.Open(strPath & "\" & strName)
.ChangeLink strOld, strNew
.Close True
End With
strName = Dir
Loop
ProcedureExit:
With Application
.AskToUpdateLinks = True
.ScreenUpdating = True
End With
End Sub
I have a VBA macro which opens up every word document for in a folder and finds a certain string in the document, and then pastes it into the open spreadsheet. All the word documents are of the same template and do contain the string in question.
It runs fine for the first 4 or 5 documents and then I get the error "pastespecial method of range class failed". The document it fails on is in no way different to the others and if I delete this document then it fails on another one. Can anyone help please? I'm new to VBA so my code may well be rubbish.
Here is the full code:
Sub readForml()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim i As Integer
Dim myWkSht As Worksheet
wdApp.Visible = False
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myExtension = "*.docx*"
Set myWkSht = ActiveSheet
myPath = "path_to_folder"
myFile = Dir(myPath & myExtension)
'set i to be furst blank row
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set myDoc = wdApp.Documents.Open(Filename:=myPath & myFile)
DoEvents
With myDoc.Content
.Find.ClearFormatting
With .Find
.Text = "number[0-9]{4}"
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.Execute
End With
.Copy
myWkSht.Range("A" & i).PasteSpecial xlPasteValues
End With
myDoc.Close SaveChanges:=False
i = i + 1
'Get next file name
myFile = Dir()
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks in advance"
There are a number of issues with this code that could be causing problems. I'm not certain any (or the combination) are the cause, but let's see...
In VBA an object shouldn't be declared and instantiated on the same line. This is OK in VB.NET, but not VBA. So declare wdApp in one line, but Set wdApp = New Word.Application in a different one.
Use a specific Range object for the Find. Currently, the code is telling Word to copy the entire document, on the one hand, but the "found" is the search term - this is confusing for VBA.
Try putting Set myDoc = Nothing just before the Loop statement to explicitly release myDoc before assigning the next document to it.
It's usually a good idea to test whether the searched term was actually found. Not sure what you want to have happen if this should occur, but it's good to have the test.
Note also that a comment is inaccurate, the code is not looping the Excel files but the Word files. This isn't causing the problem, but it should be corrected to avoid confusion.
Sub readForml()
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim wdRange as Word.Range
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim i As Integer, bFound as Boolean
Dim myWkSht As Worksheet
Set wdApp = New Word.Application
wdApp.Visible = False
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myExtension = "*.docx*"
Set myWkSht = ActiveSheet
myPath = "path_to_folder"
myFile = Dir(myPath & myExtension)
'set i to be first blank row
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set myDoc = wdApp.Documents.Open(Filename:=myPath & myFile)
DoEvents
Set wdRange = myDoc.Content
With wdRange
.Find.ClearFormatting
With .Find
.Text = "number[0-9]{4}"
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
bFound = .Execute
End With
If bFound Then
.Copy
myWkSht.Range("A" & i).PasteSpecial xlPasteValues
Else
MsgBox "Search term not found"
End If
End With
myDoc.Close SaveChanges:=False
Set myDoc = Nothing
i = i + 1
'Get next file name
myFile = Dir()
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Hi I'm facing a problem on dealing with converting Excel spreadsheets to txt files.
What I want to do is to create a Macro which can takes all the xls files in one folder and convert them to txt files.
The code currently working on
Sub Combined()
Application.DisplayAlerts = False
Const fPath As String = "C:\Users\A9993846\Desktop\"
Dim sh As Worksheet
Dim sName As String
Dim inputString As String
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
sName = Dir(fPath & "*.xls*")
Do Until sName = ""
With GetObject(fPath & sName)
For Each sh In .Worksheets
With sh
.SaveAs Replace(sName, ".xls*", ".txt"), 42 'UPDATE:
End With
Next sh
.Close True
End With
sName = Dir
Loop
With Application
.Calculation = xlAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
But It's not working as expected, I have 0 knowledge on VB. Anyone willing to give a hand?
The code below converts all Excel Workbooks (tests file extension for "xlsx") in a given folder into CSV files. File names will be [workbookname][sheetname].csv, ie "foo.xlsx" will get "foo.xlsxSheet1.scv", "foo.xlsxSheet2.scv", etc. In order to run it, create a plain text file, rename it to .vbs and copy-paste the code below. Change path info and run it.
Option Explicit
Dim oFSO, myFolder
Dim xlCSV
myFolder="C:\your\path\to\excelfiles\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
xlCSV = 6 'Excel CSV format enum
Call ConvertAllExcelFiles(myFolder)
Set oFSO = Nothing
Call MsgBox ("Done!")
Sub ConvertAllExcelFiles(ByVal oFolder)
Dim targetF, oFileList, oFile
Dim oExcel, oWB, oWSH
Set oExcel = CreateObject("Excel.Application")
oExcel.DisplayAlerts = False
Set targetF = oFSO.GetFolder(oFolder)
Set oFileList = targetF.Files
For Each oFile in oFileList
If (Right(oFile.Name, 4) = "xlsx") Then
Set oWB = oExcel.Workbooks.Open(oFile.Path)
For Each oWSH in oWB.Sheets
Call oWSH.SaveAs (oFile.Path & oWSH.Name & ".csv", xlCSV)
Next
Set oWSH = Nothing
Call oWB.Close
Set oWB = Nothing
End If
Next
Call oExcel.Quit
Set oExcel = Nothing
End Sub
You can give better file naming, error handling/etc if needed.
The issue with your code is that you define sPath as a path containing wildcard characters:
sName = Dir(fPath & "*.xls*")
and replace only the extension portion (.xls*), but leave the wildcard character before the extension in place:
Replace(sName, ".xls*", ".txt")
This produces the following path:
C:\Users\A9993846\Desktop\*.txt
which causes the error you observed, because the SaveAs method tries to save the spreadsheet to a file with the literal name *.txt, but * is not a valid character for file names.
Replace this:
.SaveAs Replace(sName, ".xls*", ".txt"), 42
with this:
Set wb = sh.Parent
basename = Replace(wb.FullName, Mid(wb.Name, InStrRev(wb.Name, ".")), "")
.SaveAs basename & "_" & sh.Name & ".txt", xlUnicodeText