VBA Help to identify files with REV numbers (Excel data is without the REV)

[dchaney]

Hello All,

I have created a VBA macro that will move files from one folder to the next based on the name of the file and the parent file. What I am having issues with is the excel file has the drawing number of the file (1234567890), and the file was saved as the drawing number and a revision number (1234567890_REV000). The rev number can change from file to file and I am not sure how to get past that. Here is what I have currently.

Sub MoveFiles() 'Designed to move files in a folder based on the information in an excel file (BP R05 - L01 Material Certs)

Dim FromPath As String, ToPath As String, FolderName As String, FileName As String
Dim lastRow As Long
Dim FSO As Object

'Turn off Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
On Error Resume Next

Set FSO = CreateObject("scripting.filesystemobject")

'Select the proper from directory
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    DialogFolder.InitialFileName = ActiveWorkbook.Path
    If DialogFolder.Show = -1 Then
        FromPath = DialogFolder.SelectedItems(1)
    Else: Set DialogFolder = Nothing
    End If
    
Set DialogFolder = Nothing

lastRow = Range("A" & Rows.Count).End(xlUp).Row

i = 9

Do Until i > lastRow

FolderName = Cells(i, 2) & " - " & Cells(i, 6) & "\"
ToPath = FromPath & FolderName
FileName = Cells(i, 7) & "_REV" & "*.pdf"

If Cells(i, 1).Interior.ColorIndex = 15 Then
        ParentFolder = Cells(i, 2).Value & " - " & Cells(i, 6).Value & "\"
        FSO.MoveFile Source:=FromPath & FileName, Destination:=ToPath
    i = i + 1
ElseIf Cells(i, 1).Interior.ColorIndex <> 15 Then
        FSO.CopyFile Source:=FromPath & FileName, Destination:=FromPath & ParentFolder
    i = i + 1
End If

Loop

Set FSO = Nothing

Kill FromPath & "*.pdf"

MsgBox "All of your files have been moved"

'Turn on Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

The issue part is FileName = Cells(i, 7) & "_REV" & "*.pdf" not sure how to get past this and have the code see 1234567890_REV000 as the 1234567890 number from my excel file.

Any help would be greatly appreciated, teaching myself VBA and it is a challenge to say the least

 

[dchaney]

I found errors in the code I pasted here (was a previous version) I had made changes to make the code work for me, if the rev version was 000, but if it is a REV 001 or other it will not work

Sub MoveFiles() 'Designed to move files in a folder based on the information in an excel file (BP R05 - L01 Material Certs)

Dim FromPath As String, ToPath As String, FolderName As String, FileName As String
Dim lastRow As Long
Dim FSO As Object

'Turn off Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
On Error Resume Next

Set FSO = CreateObject("scripting.filesystemobject")

'Select the proper from directory
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    DialogFolder.InitialFileName = ActiveWorkbook.Path
    If DialogFolder.Show = -1 Then
        FromPath = DialogFolder.SelectedItems(1) & "\"
    Else: Set DialogFolder = Nothing
    End If
    
Set DialogFolder = Nothing

lastRow = Range("A" & Rows.Count).End(xlUp).Row

i = 9

Do Until i > lastRow

FolderName = Cells(i, 2) & " - " & Cells(i, 6) & "\"
ToPath = FromPath & FolderName
FileName = Cells(i, 7) & "_REV000.pdf"

Cells(1, 15) = FromPath

If Cells(i, 1).Interior.ColorIndex = 15 Then
        ParentFolder = FromPath & Cells(i, 2) & " - " & Cells(i, 6) & "\"
        FSO.MoveFile Source:=FromPath & FileName, Destination:=ToPath
    i = i + 1
ElseIf Cells(i, 1).Interior.ColorIndex <> 15 Then
        FSO.CopyFile Source:=FromPath & FileName, Destination:=ParentFolder
    i = i + 1
End If

Loop

Set FSO = Nothing

Kill FromPath & "*.pdf"

MsgBox "All of your files have been moved"

'Turn on Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub