Copy Files From a Directory - Search For the Part No - Text String

[dj44]

Hi Folks,

Needing some assistance from the talented coders here.:grinhalo:

I want to copy word files that contain within them the text string

[Part No: followed by 6 digits]

Example.

[Part No: 285635]
[Part No: 244635]

This word is found within the document. It’s not in the file name. Now that’s why I have a headache on my hands.

I have read the good work of Mr Bruin and implemented it
http://www.rondebruin.nl/win/s3/win026.htm

I thought I would try to adapt it, but no will it do, I cant figure it out... I tried substituting the dates with the text, that didn't work
.





Sub Copy_Files()

'From Mr Bruin


Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object



'**** Search Directory - For the files




ToPath = "C:\Users\DJ-PC\TS7234\Part Nos"






If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If

If Right(ToPath, 1) <> "\" Then
ToPath = ToPath & "\"
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If

If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If

For Each FileInFromFolder In FSO.getfolder(FromPath).Files
Fdate = Int(FileInFromFolder.DateLastModified)


'Copy files Part No - Text Found in document


If InStr(1, "Part No ", " ") Then


FileInFromFolder.Copy ToPath
End If
Next FileInFromFolder

MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub






I would like to select a directory search for the files containing the Part Nos - copy them to a folder.

job done - unfortunately I've fallen flat.

Great coders please assist on how i can overcome this job....
there's so many files to check manually.

I don't mind if I run it from word or excel - whatever is the best and easiest - I just need to get those files pronto

I also tried windows search which don't get me started wasting more time than anything...:mad:

I have to manually check every file - which is more headache as the part no text is quite small so - i have to zoom in to see:old:

Thanks for helping if you can , your time is valued dear friend :hifive:

my Gratitude.
DJ

[Dave]

So U want to select a directory (folder?) and search the Word files in it for a specified part number. If the part number is found U want to copy the file to a new directory(folder). Seems fairly doable. Please confirm: that this summary is correct; how the search input directory is determined; what the output directory is; and what the Word file extension is (ie .doc or .docx etc.). I'm sure someone will be able to help if U provide a bit more info. Good luck. Dave

[dj44]

Hi Dave,

thanks for responding.:)

Yes I need to search a directory for files that only have the word Part No within the document.

Any Docx files that have a Part No - within the body text.The files are named differently like TS6348.docx , TS2736.docx etc

Copy those files to another folder.

I found this http://answers.microsoft.com/en-us/office/forum/office_2003-customize/vba-example-select-a-directory/f1c57e80-8185-48de-8c03-8bc52770a44e?auth=1
How to Select a directory, but I am afraid, I have not been able to put anything together that works.I've jumbled up the code,

It would be great if I could select the directory.I tried various file seeker software - but that's more headache gives me all sorts of wrong files.


thank you

DJ

[Dave]

Please confirm: that only "Part No" is searched for within the document and not the actual part number; how the search input directory is determined and how it is inputted; and how the output directory is is determined and inputted. Looping files in an input folder and opening them and using Find to determine if the search word exists. If it does then set a flag and close the file. Then use copyfile to copy the flagged file to an output folder. Seems like the basic outline. Dave

[gmayor]

If the Part No text is in the main body of the document as indicated in your message then the following will find and copy the documents. The 'FromPath' folder must exist, but the 'ToPath' folder will be created as a sub folder of the 'FromPath' folder if not present. The CreateFolders function uses a FolderExists function so that can also be used to test for the 'FromPath' folder. Note this only works if the searched text is in the main document body. If it is elsewhere you will need to search all the story ranges in the document.

Option Explicit
Sub Copy_Files()
Dim FromPath As String
Dim ToPath As String
Dim oDoc As Document
Dim oStory As Range
Dim strFilename As String
FromPath = "C:\Users\DJ-PC\TS7234\"
ToPath = FromPath & "Part Nos\"
If Not FolderExists(FromPath) Then
MsgBox FromPath & " doesn't exist"
GoTo lbl_Exit
End If
CreateFolders ToPath
strFilename = Dir$(FromPath & "*.docx")
While Len(strFilename) <> 0
Set oDoc = Documents.Open(FromPath & strFilename)
Set oStory = oDoc.Range
If InStr(1, oStory.Text, "Part No ") > 0 Then
oDoc.SaveAs2 Filename:=ToPath & oDoc.Name, AddToRecentFiles:=False
End If
oDoc.Close SaveChanges:=0
strFilename = Dir$()
Wend
MsgBox "You can find the files from " & FromPath & vbCr & "in" & vbCr & ToPath
lbl_Exit:
Set oStory = Nothing
Set oDoc = Nothing
Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'Graham Mayor
'Create any missing folders in a named file path
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

[Dave]

Sweet! I'm gonna read up on the InStr & SaveAs2 stuff. Any chance the InStr is quicker than using find? Thanks Graham for not making me bludgeon out a new wheel. Dj44 I hope Grahams contribution has helped U out. Dave

[gmayor]

There is not much in it in terms of speed, but if you want to experiment, change

If InStr(1, oStory.Text, "Part No ") > 0 Then
oDoc.SaveAs2 Filename:=ToPath & oDoc.Name, AddToRecentFiles:=False
End If

to

With oStory.Find
Do While .Execute(FindText:="Part No ")
oDoc.SaveAs2 Filename:=ToPath & oDoc.Name, AddToRecentFiles:=False
Exit Do
Loop
End With

[dj44]

Hello Graham,

You are Top chief like Neo the coder, I am humbled by your help so thank you.:grinhalo:

I have revved up this fine macro and as far as I can see - it worked like a treat.

It found the files and made a copy into a nice folder.

I just need to know one last thing, please - if you or any one has any ideas - how do I get to those subfolders.

now they have a lot of garbage files stored in them with Part No files.

I am trying to reorganize a big hard drive of zillions of files dumped there, my work is there lost in there somewhere.:work:

Thats why I was trying to select the directory so it could search it.

some one told me to use abatch on the shell but that's too complicated for me.

Graham in your own time, of you don't mind me taking advantage of your help - how can i get to those subfolders.

And thank you very very much on this fine fine macro

I owe you a big buddy cheers :clap:


DJ

[gmaxey]

DJ,

What sub-folders are you talking about? Do you mean that you want to search C:\Users\DJ-PC\TS7234\ and any sub-folders it contains If so then you are going to have collect all of those folders using a recursive routine. Since doing so requires as the file system object right away, I just included some of Graham's functions in the main routine.



Option Explicit
Private m_colFolders As New Collection
Private m_oFSO As Object
Sub Copy_Files()
Dim strSourceFolder As String, strMoveToFolder As String
Dim oFolder As Object
Dim oFile As Object
Dim oDoc As Document
Dim lngFolder As Long, lngCount As Long

strSourceFolder = "C:\Users\DJ-PC\TS7234\"
strMoveToFolder = strSourceFolder & "Part Nos"
Set m_oFSO = CreateObject("Scripting.FileSystemObject")
If m_oFSO.FolderExists(strSourceFolder) Then
Set oFolder = m_oFSO.GetFolder(strSourceFolder)
CollectFolders oFolder, True
Else
MsgBox strSourceFolder & " doesn't exist"
GoTo lbl_Exit
End If
If Not m_oFSO.FolderExists(strMoveToFolder) Then MkDir strMoveToFolder
For lngFolder = 1 To m_colFolders.Count
Set oFolder = m_oFSO.GetFolder(m_colFolders.Item(lngFolder))
For Each oFile In oFolder.Files
Select Case oFile.Type
Case "Microsoft Word Document", "Microsoft Word Macro-Enabled Document"
Application.StatusBar = "Opening " & oFile.Name
Debug.Print oFile.Name
Set oDoc = Documents.Open(oFile.Path, , , False, , , , , , , , False)

If InStr(1, oDoc.Content, "Part No ") > 0 Then
oDoc.Close SaveChanges:=0
oFile.Move strMoveToFolder & Application.PathSeparator & oFile.Name
lngCount = lngCount + 1
Else
oDoc.Close SaveChanges:=0
End If
End Select
Next oFile
Next lngFolder
MsgBox lngCount & " files were found and moved to " & strMoveToFolder
lbl_Exit:
Set oDoc = Nothing
Exit Sub
End Sub

Sub CollectFolders(oFolder As Object, Optional bFirstCall As Boolean)
Dim SubFolder As Object
If bFirstCall Then m_colFolders.Add oFolder.Path
On Error Resume Next
For Each SubFolder In oFolder.SubFolders
m_colFolders.Add SubFolder.Path, SubFolder.Path
Set oFolder = m_oFSO.GetFolder(SubFolder.Path)
CollectFolders SubFolder
Next SubFolder
lbl_Exit:
On Error GoTo 0
Exit Sub
End Sub

[dj44]

Hello Greg,

This charming code has done the job, the wheels are complete now.


I learned to change 1 word to


oFile.Copy strMoveToFolder & Application.PathSeparator & oFile.Name

thank your jumping into help my battered old hardrive.

On its last leg - needed those files like yesteryear. :checkmark

I can now get on with copying and moving files, :type


Those folders and files had no chance against the mighty coders of this forum.

Thanks to Graham and to you Greg for solving the case

buddy cheers and you all have a great weekend now :grinhalo:


:peace:



DJ