Hello VBA Guru's, I have this code which I use to search a directory for a word doc and if it exist in the spreadsheet then it copies that file to a new directory and marks on the spreadsheet as moved, Recently we changed from Word docs to PDF files and I cant work out how to make it do the exact same thing for PDF files . Any assistance would be greatly appreciated
Sub CopyDocs()
Dim fldr As FileDialog
Dim sItem As String
Dim c As Object
Dim Path As String
Dim FName As String
Dim SPath As String
Dim wd As Word.Application
Set wd = CreateObject("word.application")
wd.Visible = False
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
With ActiveSheet
Lrow = ActiveSheet.Cells(1500, 2).End(xlUp).Row
For Each c In .Range("B2:B" & Lrow)
Path = sItem
FName = Dir(Path & "\*.doc*")
Do
If InStr(FName, c) > 0 And c <> "" Then
On Error Resume Next
MkDir (ThisWorkbook.Path & "" & ActiveSheet.Name)
MkDir (ThisWorkbook.Path & "" & ActiveSheet.Name & "\Review")
On Error Resume Next
If .Cells(c.Row, "L") = "" Then
On Error Resume Next
wd.Documents.Open Filename:=Path & "" & FName
wd.ActiveDocument.SaveAs (ThisWorkbook.Path & "" & ActiveSheet.Name & "\Review" & FName)
wd.ActiveDocument.Close
c.Offset(, 10) = "Moved"
End If
End If
FName = Dir()
Loop Until FName = ""
Next c
End With
NextCode: Exit Sub
wd.Quit
Set fldr = Nothing
Set wd = Nothing
End Sub
Sub CopyDocs()
Dim fldr As FileDialog
Dim sItem As String
Dim c As Object
Dim Path As String
Dim FName As String
Dim SPath As String
Dim wd As Word.Application
Set wd = CreateObject("word.application")
wd.Visible = False
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
With ActiveSheet
Lrow = ActiveSheet.Cells(1500, 2).End(xlUp).Row
For Each c In .Range("B2:B" & Lrow)
Path = sItem
FName = Dir(Path & "\*.doc*")
Do
If InStr(FName, c) > 0 And c <> "" Then
On Error Resume Next
MkDir (ThisWorkbook.Path & "" & ActiveSheet.Name)
MkDir (ThisWorkbook.Path & "" & ActiveSheet.Name & "\Review")
On Error Resume Next
If .Cells(c.Row, "L") = "" Then
On Error Resume Next
wd.Documents.Open Filename:=Path & "" & FName
wd.ActiveDocument.SaveAs (ThisWorkbook.Path & "" & ActiveSheet.Name & "\Review" & FName)
wd.ActiveDocument.Close
c.Offset(, 10) = "Moved"
End If
End If
FName = Dir()
Loop Until FName = ""
Next c
End With
NextCode: Exit Sub
wd.Quit
Set fldr = Nothing
Set wd = Nothing
End Sub