I am a beginner with Excel VBA and have some questions.
I want to search a specified folder based on user input (a file name). I can get that part to work, however, I want it to search for more than just the one format (.docx), and also include a search of both .pdf and .doc.
Clarification:
The folder under G:\NEWFOLDER\NAMEFOLDER contains files with extensions .doc, .docx, and .pdf and I want to search the entire folder and report back to my spreadsheet on Sheet2.
Dim NAME As String
Dim File_Path As String
NAME = InputBox(" Enter Your NAME (EX: JOHNP) ")
File_Path = "G:\NEWFOLDER\NAMEFOLDER" & NAME & ".docx"
If Dir(File_Path) <> "" Then
ThisWorkbook.Sheets("Sheet2").Activate
Range("D5") = ("Checked")
Range("E5") = NAME
Else
MsgBox "NAME Not found"
End If
End Sub
How do I search the document within?
Clarification:
The above code only tells me if the user input is located inside the coded path. The next step I want to do is to search within that document for keyword and report back to spreadsheet. For example, within JOHNP.doc there is a column of age. I want the code to report back to Sheet2 cell with "22".
Is this even possible with word document search, or is it better if the JOHNP is in excel format?
This should help you a little bit - This will cycle through files in the named folder location (if it exists), and will only target ones that are .doc, .docx or .pdf.
As for your second question - Yes, you can pull that number from your documents, however, you'll need to be more specific as to where that number is. If it's in the same spot each time, then that would be fairly easy - hopefully in a Table, then it would have an explicit reference (like ActiveDocument.Tables(1).Cells(1,1), etc. For now, this code below will go through all the files and when it finds the first match, it'll open the word document for you (then exit the loop).
Sub Test()
Dim NAME As String
Dim File_Path As String
Dim StrFile As String
NAME = InputBox(" Enter Your NAME (EX: JOHNP) ")
File_Path = "G:\NEWFOLDER\NAMEFOLDER\" & NAME & "\"
StrFile = Dir(File_Path)
If Dir(File_Path) <> "" Then
Do While Len(StrFile) > 0
If InStr(StrFile, ".doc") > 0 Or _
InStr(StrFile, ".pdf") > 0 Then
Debug.Print StrFile
'ThisWorkbook.Sheets("Sheet2").Range("D5") = ("Checked")
'ThisWorkbook.Sheets("Sheet2").Range("E5") = NAME
If InStr(StrFile, ".doc") > 0 Then
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open File_Path & StrFile
wordapp.Visible = True
Exit Do
End If
End If
StrFile = Dir
Loop
Else
MsgBox NAME & " Not found"
End If
End Sub
Related
I need to loop over some word documents, and extract images from a word document and save them in a separate folder.
I've tried the method of saving them as an HTML document, but it is not a good fit for my requirement.
Now, I'm looping through the images using inlineshapes object and then copy-pasting them on a publisher document and then saving them as an image. However, I'm facing a Runtime Automation error when I'm running the script.
For using the Publisher runtime library I've tried both early and late binding but I'm facing the error on both of them.
Can anyone please let me know what is the problem? Also, if anyone can explain why I'm facing this error, that'd be great. As per my understanding, it is due to memory allocation, but I'm not sure.
Here is the code block that I've been working on (fp, dp are folder paths, while filename is the word document name. I'm calling this sub in another sub that is looping over all the files in a folder):
Sub test(ByVal fp As String, ByVal dp As String, ByVal filename As String)
Dim doc As Document
Dim pubdoc As New Publisher.Document
Dim shp As InlineShape
'Application.Screenupdating = False
'Dim pubdoc As Object
'Set pubdoc = CreateObject("Publisher.Document")
Set doc = Documents.Open(fp)
With doc
i = .InlineShapes.Count
Debug.Print i
End With
For j = 1 To i
Set shp = doc.InlineShapes(j)
shp.Select
Selection.CopyAsPicture
pubdoc.Pages(1).Shapes.Paste
pubdoc.Pages(1).Shapes(1).SaveAsPicture (dp & Application.PathSeparator & j & ".jpg")
pubdoc.Pages(1).Shapes(1).Delete
Next
doc.Close (wdDoNotSaveChanges)
pubdoc.Close
'Application.Screenupdating = True
End Sub
Apart from this, if anyone has any suggestions to make this faster, I'm all ears. Thanks in advance!
Just add .zip to the end of the file name, expand the file and look in the word/media folder. All the files will be there, no programming necessary.
Extracting the pictures from a Filtered HTML document that was created from your original source document would be faster. However, you said that was not a good fit for you needs so ... here is example code that will locate pictures in your source document and paste them into a second document.
The speed problem of this type of code is caused by the CopyPicture working from a Selection command, so I recommend using a range instead. Of course the For/Next loop that is required is slower no matter what.
Sub CopyPasteAsPicture()
Dim doc As Word.Document, iShp As Word.InlineShape, shp As Word.Shape
Dim i As Integer, nDoc As Word.Document, rng As Word.Range
Set doc = ActiveDocument
If doc.Shapes.Count > 0 Then
For i = 1 To doc.Shapes.Count
Set shp = doc.Shapes(i)
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
'if you want only pictures extracted then you have
'to specify the type
shp.ConvertToInlineShape
'if you want all extracted pictures to be in the sequence
'they appear in the document then you have to convert
'floating shapes to inline shapes
End If
Next
End If
If doc.Content.InlineShapes.Count > 0 Then
Set nDoc = Word.Documents.Add
Set rng = nDoc.Content
For i = 1 To doc.Content.InlineShapes.Count
doc.Content.InlineShapes(i).Range.CopyAsPicture
rng.Paste
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
rng.Paragraphs.Add
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Next
End If
End Sub
If you want to place all shapes (floating or inline) into a folder as image files, then the best way is to save the source document as a filtered HTML document. Here is the command:
htmDoc.SaveAs2 FileName:=LGPWorking & strFileName, AddToRecentFiles:=False, FileFormat:=Word.WdSaveFormat.wdFormatFilteredHTML
In the above the active document is assigned to the variable htmDoc. I am giving this new document a specific name and location. The output from this is not only the HTML file but also a directory by the same name with an appended "_Files" label. In the "x_Files" directory are all the image files.
If you only want selective images pulled from your original source document, or if you want images pulled from multiple source documents ... then you need to use the above code that I shared for placing only the images you want from one or more source document into a new Word document and then save that new document as an Filtered HTML.
When your routine is done, you can Kill the HTML document and only leave the Files directory.
I had to change a few things around, but this will allow to save a single image on a word document and go through a couple of cycles before it turns into a jpg on the other side, without any white space
filename = ActiveDocument.FullName
saveLocaton = "z:\temp\"
FolderName = "test"
On Error Resume Next
Kill "z:\temp\test_files\*" 'Delete all files
RmDir "z:\temp\test_files" 'Delete folder
ActiveDocument.SaveAs2 filename:="z:\temp\test.html", FileFormat:=wdFormatHTML
ActiveDocument.Close
Kill saveLocaton & FolderName & ".html"
Kill saveLocaton & FolderName & "_files\*.xml"
Kill saveLocaton & FolderName & "_files\*.html"
Kill saveLocaton & FolderName & "_files\*.thmx"
Name saveLocaton & FolderName & "_files\image00" & 1 & ".png" As saveLocaton & FolderName & "_files\" & test2 & "_00" & x & ".jpg"
Word.Application.Visible = True
Word.Application.Activate
We have a system that automatically downloads data and puts it in excel and other sheets. I am trying to write a macro for a master spreadsheet that retrieves the latest version of a certain file to edit, copy and paste into the master sheet.
I have trouble retrieving the file as the filenames include dates.
I am quite new to VBA and am still just throwing pieces of code together to get a working thing, but I cannot find exactly what I am looking for.
Filename is for example 'ML0003 - Daily Order Entry Information - 170927'
The last 6 figures represent the date and changes every time.
This is my code so far:
Dim dtTestDate As Date
Dim sStartWB As String
Const sPath As String = "D:\Berry\AddIn\Testing\"
Const dtEarliest = #1/1/2010#
dtTestDate = Date
sStartWB = ActiveWorkbook.Name
While ActiveWorkbook.Name = sStartWB And dtTestDate >= dtEarliest
On Error Resume Next
Workbooks.Open sPath & "ML0003 - Daily Order Entry Information - " & " ****** " & ".xls"
dtTestDate = dtTestDate - 1
On Error GoTo 0
Wend
If ActiveWorkbook.Name = sStartWB Then MsgBox "Earlier file not found."
I was under the assumtion that the asterix would allow any character there, but this does not seem to work. Any ideas?
You will want to use the Dir function to look for a file using the wildcard, like this:
Dim sFilename As String
While ActiveWorkbook.Name = sStartWB And dtTestDate >= dtEarliest
sFilename = Dir(sPath & "ML0003 - Daily Order Entry Information - *.xls*")
If sFilename <> "" Then Workbooks.Open sPath & sFilename
Wend
I am currently working on user customisability in VBA while searching through some other workbooks. I am having issues converting my FileName expression in the Dir() function into a path directory with the correct backslash after my folder name, and then using wildcards around File to allow Dir to search for all occurrences of a keyword. Currently I believe the \ is omitted, and I can't yet tell if my wildcards are working
' Modify this folder path to point to the files you want to use.
Folder = InputBox("Enter folder directory of files")
' e.g C:\peter\management\Test Folder
File = InputBox("Enter filename keyword")
'e.g. PLACE
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(Folder & "\" & "*" & File & "*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
I am assuming my syntax is incorrect for what I am trying to achieve. Any help would be appreciated!
EDIT:
' Modify this folder path to point to the files you want to use.
Folder = InputBox("Enter folder directory of files")
' e.g C:\peter\management\Test Folder
File = InputBox("Enter filename keyword")
'e.g. PLACE
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(Folder & "\" & File & "*" & ".xls")
Debug.Print (FileName)
' Loop until Dir returns an empty string.
Do While FileName <> ""
Is what I am currently working with. The "\" in my Dir line doesn't seem to do anything as I still have to add the final \ before the file manually for it to appear in my error message.
When I tried your code it worked for me. Needless to say, that makes it a little tricky to provide a satisfactory answer!
Below is my attempt to solve the same problem.
Instead of asking the user to manually type the folder address I've used Excel's built-in folder picker. This avoids the need to check for and deal with typos.
Sub FindFiles()
Dim fldDialog As FileDialog ' Holds a reference to the folder picker.
Dim path As String ' Folder selected by user.
Dim fileFilter As String ' Provided by user, wildcard supported.
Dim found As String ' Used to display returned results.
' Config dialog.
Set fldDialog = Application.FileDialog(msoFileDialogFolderPicker)
fldDialog.Title = "Pick a folder" ' Caption for dialog.
fldDialog.AllowMultiSelect = False ' Limit to one folder.
fldDialog.InitialFileName = "C:\" ' Default starting folder.
' Display to user.
If fldDialog.Show Then
' Config filter.
path = fldDialog.SelectedItems(1)
fileFilter = InputBox("Select a filter (*.*)", "File filter", "*.*")
' Get results.
found = Dir(path & "\" & fileFilter)
Do Until found = vbNullString
MsgBox found, vbInformation, "File found"
found = Dir()
Loop
Else
MsgBox "User pressed cancel", vbInformation, "Folder picker"
End If
End Sub
I am relatively amateur at VBA and am using a code provided by tech on the net.
I have an Excel document with files names in column B (not always one file type) which I am trying to ensure I have copies and the correct revision in a designated folder.
Currently, the code works perfectly for a specific folder location, but the files referenced in the Excel spreadsheet exist in various other folders and thus I need to create a code that can search a main folder and loop through the various sub-folders.
See current code below for reference.
Sub CheckIfFileExists()
Dim LRow As Integer
Dim LPath As String
Dim LExtension As String
Dim LContinue As Boolean
'Initialize variables
LContinue = True
LRow = 8
LPath = "K:\location\main folder\sub folder \sub folder"
LExtension = ".pdf"
'Loop through all column B values until a blank cell is found
While LContinue
'Found a blank cell, do not continue
If Len(Range("B" & CStr(LRow)).Value) = 0 Then
LContinue = True
'Check if file exists for document title
Else
'Place "No" in column E if the file does NOT exist
If Len(Dir(LPath & Range("B" & CStr(LRow)).Value & LExtension)) = 0 Then
Range("E" & CStr(LRow)).Value = "No"
'Place "Yes" in column E if the file does exist
Else
Range("E" & CStr(LRow)).Value = "Yes"
End If
End If
LRow = LRow + 1
Wend
End Sub
There are over 1000 documents, so simple windows searches is not ideal, and I have reviewed several previous questions and cannot find an answer that helps.
Okay, my answer is going to revolve around 2 comments from your question. This will serve only as a basis for you to improve upon and adapt to how you need it.
N.B SKIP TO THE BOTTOM OF MY ANSWER TO SEE THE FULL WORKING CODE
The first comment is:
I need to create a code that can search a main folder and loop through the various sub-folders.
The code i will explain below will take a MAIN FOLDER, that you will need to specify, and then it will loop through ALL subfolders of the parent directoy. So you will not need to worry about specific sub folders. As long as you know the name of the file you want to access, the code will find it regardless.
The second is a line of your code:
LPath = "K:\location\main folder\sub folder \sub folder"
This line of code will form part of a UDF (User Defined Function) that i will display below.
Step 1
Re-label LPath to be the what is called the "Host Folder". This is the MAIN FOLDER.
For Example: Host Folder = "K:\User\My Documents\" (Note the backslash at the end is needed)
Step 2
Set a reference to Microsoft Scripting Runtime in 2 places:
i) In the code
Set FileSystem = CreateObject("Scripting.FileSystemObject")
ii) In the VBA Editor. (To a basic google search on how to find the reference library in the VBA editor)
Step 3
This is the main element, this is a sub routine that will find the file no matter where it is, providing a file name and host folder has been provided.
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
If File.Name = "Specify Name.pdf" Then
Workbooks.Open (Folder.path & "\" & File.Name), UpdateLinks:=False
Workbooks(File.Name).Activate
Exit Sub
End If
Next
End Sub
The code above will simply open the file once it has found it. This was just my own specific use; adapt as necessary.
MAIN CODE
Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Sub FindFile()
HostFolder = "K:\User\My Documents\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
If File.Name = "Specify Name.pdf" Then
Workbooks.Open (Folder.path & "\" & File.Name), UpdateLinks:=False
Workbooks(File.Name).Activate
Exit Sub
End If
Next
End Sub
You can chop this up how you see fit, you can probably throw it into your sub CheckIfFileExists() or just use it on its own.
Let me know how you get along so i can help you understand this further
Using Word VBA Macros, can I rename (append) a .doc file with value contained in a bookmark.
for eg, I have a bookmark "name" present in thousands of documents in a folder 'source'. Each file has a different value in the bookmark, eg, Richard, Alex, William, etc.
If my file is, say, "123.doc", containing bookmark "name" with value "Richard"
then I want the word file to be renamed "123Richard.doc"
and if 456.doc, again containing same bookmark "name" with value "Alex",
then I want the word fiile to be renamed "456Alex.doc"
I want to use only word VBA Macros.
Thank you.
To rename the single doc you can use this:
Public Sub updateName()
Dim name As String
If ActiveDocument.Bookmarks.Exists("BookMarkName") Then
'extract the name from the bookmark
name = ActiveDocument.Bookmarks("BookmarkName").Range.Text
'Save the doc with the new name
ActiveDocument.SaveAs _
Left(ActiveDocument.FullName, Len(ActiveDocument.FullName) - 4) & _
name & Right(ActiveDocument.FullName, 4)
End If
End Sub
To do this in all docs in a specific subfolder you can use a traversal macro, check out this code from VBA express: http://www.vbaexpress.com/kb/getarticle.php?kb_id=76
It will open alle files in a specific folder and all its subfolder. Just add a call to updateName inside the loop:
If Right(strName, 4) = ".doc" Or Right(strName, 4) = ".dot" Then
Set wdDoc = Documents.Open(FileName:=strPath & "\" & strName, _
ReadOnly:=False, Format:=wdOpenFormatAuto)
'Call the macro that performs work on the file pasing a reference to it
'change the name of the open document
changeDoc
'we close saving changes
wdDoc.Close wdSaveChanges
End If
UPDATE:
Rename the document based on the values in two bookmarks:
Public Sub updateName2()
Dim firstName, lastName As String
'make sure the bookmarks exist
If ActiveDocument.Bookmarks.Exists("FNAME") And _
ActiveDocument.Bookmarks.Exists("LNAME") Then
'extract the names
firstName = ActiveDocument.Bookmarks("FNAME").Range.Text
lastName = ActiveDocument.Bookmarks("LNAME").Range.Text
'save the document with the new name
ActiveDocument.SaveAs _
ActiveDocument.path & "\" & firstName & _
" " & lastName & ActiveDocument.name
End If
End Sub