I have created this macro script that suppose to do the following:
Ask the user to select a directory.
Search for all docx files in the selected directory.
For each file found:
Open the file.
Replace a wildcard with an empty string.
Save the file
For some reason, text is not being replaced and the file is not saved.
Sub Remove_time_blocks()
Dim WdDoc As Document, sFile As String
Dim FilePath As String
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = Application.FileDialog( _
FileDialogType:=msoFileDialogFolderPicker)
If dlgSaveAs.Show = -1 Then
FilePath = dlgSaveAs.SelectedItems(1)
sFile = Dir(FilePath & "/*.docx")
'Loop through all .doc files in that path
Do While sFile <> ""
Set WdDoc = Application.Documents.Open(FilePath & "\" & sFile)
With WdDoc.Content.Find
.Forward = True
.Wrap = wdFindStop
.Text = "^l^l[0-9]{1,}^l*:*--*,[0-9]{3}"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll, Forward:=True
End With
WdDoc.Save
sFile = Dir
Loop
End If
End Sub
Related
This is code derived from Mail Merge Tips and Tricks.
Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Number") & "_" & .DataFields("Name") & "_Test"
End With
.Execute Pause:=False
End With
StrName = Trim(StrName)
With ActiveDocument
.SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.PrintOut Copies:=1
.Close SaveChanges:=False
End With
Next i
End With
Application.ScreenUpdating = True
End Sub
The code separates a serial letter into individual files, saves them as pdf and starts the printing.
The macro saves all the files in the same folder and I have to move each file to the designated folder manually (each file has an own folder with the "Number" from the code as its name).
Is it possible to save the files directly in the intended folder?
I'd do something like this:
Dim num, numGen as long, f, StrFolder As String
'...
'...
num = .DataFields("Number") 'capture the value in the With .DataSource block
'...
'...
'check if the destination folder exists
f = FindFolder(StrFolder, CStr(num)) 'returns folder path if exists
If Len(f) = 0 Then
'no match was found - use a generic folder
f = StrFolder & "General" 'or whatever you want
numGen = numGen + 1
End If
.SaveAs2 FileName:= f & _
Application.PathSeparator & StrName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'...
'...
'Notify that some files need to be moved
If numGen > 0 Then
Msgbox numGen & " files were saved to 'General' folder"
End If
This function will return the path of any matched folder given a starting folder to begin in (includes searching in subfolders). Returns empty string if no match.
Function FindFolder(StartAt As String, ByVal folderName As String) As String
Dim colFolders As New Collection, sf, path, fld, fso
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add StartAt
Do While colFolders.Count > 0
fld = colFolders(1)
colFolders.Remove 1
If Right(fld, 1) <> "\" Then fld = fld & "\"
For Each sf In fso.getfolder(fld).subfolders
If sf.Name = folderName Then
FindFolder = sf.path
Exit Function
Else
colFolders.Add sf
End If
Next sf
Loop
End Function
Your code is derived from the Send Mailmerge Output to Individual Files article in the Mailmerge Tips & Tricks thread, at https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html.
That article contains code for setting the save path and tells you how to use it...
I am trying to make a copy of a workbook that I have, based on list of IDs. I have got this to work OK if I hard code the path, however I can't figure out how to do this where specifying the path using msoFileDialogFolderPicker.
I have tried a number of variations depending on what I have found online and have got as far as below but stuck. Help appreciated.
Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"
With xFilepath
.Title = "Choose Destination"
.SHOW
mypath = .SelectedItems(1) & "\"
End With
mypath = mypath
Sheets("FILES").Range("A3").Select
For i = 1 To 3
Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")
ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
FileFormat = 50
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=mypath & Filename
Call DeleteQueries
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You can use the following code can be used to select folder and then you can append the folder path with file name.
Sub ChooseFolder()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
Filename = "Test.xlsx"
Filepath = sFolder + "\" + Filename
If sFolder <> "" Then ' if a file was chosen
MsgBox Filepath 'Use this for further processing
End If
End Sub
Following code can be used select single file.
Private Sub ChooseFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Excel File", "*.xlsx"
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
MsgBox txtFileName
End Sub
I want to update text in numerous Word files (in a lot of folders and sub folders). I have a function to loop through all of them.
I want to find and replace in the whole document. I can see the files are being opened and closed, but at the end nothing is saved.
Sub UpdateOneFolderToUnicode()
Dim strFolder As String, strFile As String
strFolder = "my folder here"
If strFolder = "" Then Exit Sub
'strFile = Dir(strFolder & "\*.docx", vbNormal) ' for docx files
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
updateOneFile strFolder & "\" & strFile
strFile = Dir()
Wend
End Sub
Sub updateOneFile(filePath)
Dim wdDoc As Document
Application.ScreenUpdating = True
On Error GoTo UpdateErr
Set wdDoc = Documents.Open(FileName:=filePath, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .Range.Find
.Text = "~"
.Replacement.Text = ChrW(625)
.Wrap = wdFindContinue
.MatchCase = True
End With
.Range.Find.Execute Replace:=wdReplaceAll
End With
wdDoc.Close SaveChanges:=True
Set wdDoc = Nothing
Application.ScreenUpdating = True
Exit Sub
UpdateErr:
Debug.Print "Update file: " & filePath & " Error: " & Err.Description
Set wdDoc = Nothing
End Sub
there is no errors.
and I made it work by updating part of the code to:
Set wdDoc = Documents.Open(FileName:=filePath, AddToRecentFiles:=False, Visible:=False)
Set myRange = wdDoc.Content
With myRange.Find
.Text = "Ä"
.Replacement.Text = ChrW(256)
.Wrap = wdFindContinue
.MatchCase = True
End With
myRange.Find.Execute Replace:=wdReplaceAll
Basically use Content instead of Range, and I have to put the wdDoc.Conent into a variable, otherwise still not working (not sure why).
Sub ReplaceEntireHdr()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
'Change the directory to YOUR folder's path
fName = Dir("C:\Users\user1\Desktop\A\*.doc")
Do While (fName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Users\user1\Desktop\A\" & fName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.ActiveDocument.Close
End With
fName = Dir
Loop
Set wrd = Nothing
End Sub
I use this vba code to replace all the headers, of all the word documents in a folder 'A'. However if there is any subfolder in the parent folder 'A' with word documents, the vba code skips those documents. Could anyone please tell me how to include the word documents in the subfolders as well? Perhaps by making some changes in the code or any other vba code which can do the same job.
Thanks in advance.
In order to pick up the folders (directories) you need to specify the vbDirectory attribute. By default, Dir only "sees" things that match vbNormal.
Here's an example that picks up both files and sub-directories. The GetAttr function checks whether the file attribute is vbDirectory. If it's not, then it's a file.
What you can do is save the directory paths in an array, then loop that to get the files in the sub-directories.
Sub GetFilesandSubDir()
Dim sPath As String, sPattern As String
Dim sSearch As String, sFile As String
Dim sPathSub As String, sSearchSub As String
Dim aSubDirs As Variant, i As Long
sPattern = "*.*"
sPath = "C:\Test\"
sSearch = sPath & sPattern
sFile = Dir(sPath, vbNormal + vbDirectory)
aSubDirs = TestDirWithSubFolders(sPath, sPattern, sSearch, sFile)
For i = LBound(aSubDirs) To UBound(aSubDirs)
Debug.Print "Directory: " & aSubDirs(i)
sPathSub = sPath & aSubDirs(i) & "\"
sSearchSub = sPathSub & sPattern
sFile = Dir(sPathSub, vbNormal + vbDirectory)
TestDirWithSubFolders sPathSub, sPattern, sSearchSub, sFile
Next
End Sub
Function TestDirWithSubFolders(sPath As String, sPattern As String, _
sSearch As String, sFile As String) As Variant
Dim aSubDirs() As Variant, i As Long
i = 0
Do While sFile <> ""
If GetAttr(sPath & sFile) = vbDirectory Then
'Debug.Print "Directory: " & sFile
ReDim Preserve aSubDirs(i)
aSubDirs(i) = sFile
i = i + 1
Else
Debug.Print "File: " & sFile
End If
sFile = Dir
Loop
TestDirWithSubFolders = aSubDirs
End Function
[Using MS Word 2010]
I have a macro that converts a Word document from docx format to txt format. However there are some documents that stop during conversion with the following notification: "The document may contain text content that will be lost upon conversion to the chosen encoding. To preserve this content , click No to exit this dialog box,and then choose another encoding that supports the languages in this document.
Do you want to continue saving the document? Yes/No"
Of course I want to continue to save the document as txt so I have to click the Yes button. I am converting hundreds of documents (docx) to text and want the macro to intercept this message and tell Word 'Yes" without my intervention. Can anyone tell me the VBA code needed to accomplish this and where in my macro does it need to go? I am a complete novice to VBA. I found the following VBA code on the Internet and it works fine except for what I just indicated about the Word message. Here is the code:
Sub ChangDocsToTxtOrRTForHTML()
'with export to PDF in word 2007
Dim fs As Object
Dim oFolder As Object
Dim tFolder As Object
Dim oFile As Object
Dim strDocName As String
Dim intPos As Integer
Dim locFolder As String
Dim fileType As String
On Error Resume Next
locFolder = InputBox("Enter the folder path do DOCs", "File Conversion", "C:\myDocs")
Select Case Application.Version
Case Is < 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML")
Case Is >= 12
Do
fileType = UCase(InputBox("Change DOC to TXT, RTF, HTML, or PDF(2007+ only)", "File Conversion", "TXT"))
Loop Until (fileType = "TXT" Or fileType = "RTF" Or fileType = "HTML" Or fileType = "PDF")
End Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set oFolder = fs.GetFolder(locFolder)
Set tFolder = fs.CreateFolder(locFolder & "Converted")
Set tFolder = fs.GetFolder(locFolder & "Converted")
For Each oFile In oFolder.Files
Dim d As Document
Set d = Application.Documents.Open(oFile.Path)
strDocName = ActiveDocument.Name
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
ChangeFileOpenDirectory tFolder
Select Case fileType
Case Is = "TXT"
strDocName = strDocName & ".txt"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText
Case Is = "RTF"
strDocName = strDocName & ".rtf"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatRTF
Case Is = "HTML"
strDocName = strDocName & ".html"
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatHTML
Case Is = "PDF"
strDocName = strDocName & ".pdf"
'*** Word 2007 users - remove the apostrophe at the start of the next line ***
'ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF
End Select
d.Close
ChangeFileOpenDirectory oFolder
Next oFile
Application.ScreenUpdating = True
End Sub
Sub ConvertFiles()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.txt", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
Format:=wdOpenFormatEncodedText, Encoding:=msoEncodingUTF8, _
AddToRecentFiles:=False, Visible:=False)
wdDoc.SaveAs2 FileName:=strFolder & "\" & Replace(strFile, ".txt", ".docx"), _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
wdDoc.Close SaveChanges:=False
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Thank you for your help.
ntman2
For text files, Word is able to use different encoding schemes for saved-as files that can avoid generating this warnings. Try:
ActiveDocument.SaveAs _
FileName:=strDocName, _
Fileformat:=wdFormatText, _
Encoding:=msoEncodingUnicodeLittleEndian
instead of:
ActiveDocument.SaveAs FileName:=strDocName, Fileformat:=wdFormatText