Copy Files From Folder Not All Characters

[Dippy001]

Hi MrExcel Experts

I was wondering if you may be able to help me with a situation I am currently stuck with.

I require a VBA that looks into a folder location and sees if the file is there copies the data from the sheet and imports it into my active sheet without opening the file if it does not exist it throws an error message

The file name would be from the active sheet that it is looking for and also it it will be a partial file name for example

So from the drop down the file name is chosen

Then the macro would run and select the file from the folder location provided in the macro

The file then is selected from the folder ignoring all the other charachets at the end of the name

Name 1 is selected

then it copys the data from Name 1 15.10.2023 14.24 and pastes it excluding the headers into the main sheet with also the file name it copied it from

I hope this make sense and someone has the ability to help me in this perdicument, Thank you

 

[John_w]

Try this macro, after changing the folder path in the code.

Public Sub Import_Partial_File_Name_Workbook()
    
    Dim folder As String, matchFile As String, fileName As String
    Dim wb As Workbook
    
    folder = "C:\path\to\Test\"    'CHANGE THIS PATH
    
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    
    With ActiveSheet
        matchFile = .Range("C6").Value & "*.xls*"
        fileName = Dir(folder & matchFile)
        If fileName <> vbNullString Then
            Application.ScreenUpdating = False
            Set wb = Workbooks.Open(folder & fileName)
            wb.Worksheets(1).UsedRange.Offset(1).Copy .Range("H7")
            wb.Close False
            .Range("D6").Value = Left(fileName, InStrRev(fileName, ".") - 1)
            Application.ScreenUpdating = True
        Else
            MsgBox "No files matching '" & matchFile & "' exist in " & folder, vbInformation
        End If
    End With

End Sub

 

[Dippy001]

Try this macro, after changing the folder path in the code.

Public Sub Import_Partial_File_Name_Workbook()
   
    Dim folder As String, matchFile As String, fileName As String
    Dim wb As Workbook
   
    folder = "C:\path\to\Test\"    'CHANGE THIS PATH
   
    If Right(folder, 1) <> "\" Then folder = folder & "\"
   
    With ActiveSheet
        matchFile = .Range("C6").Value & "*.xls*"
        fileName = Dir(folder & matchFile)
        If fileName <> vbNullString Then
            Application.ScreenUpdating = False
            Set wb = Workbooks.Open(folder & fileName)
            wb.Worksheets(1).UsedRange.Offset(1).Copy .Range("H7")
            wb.Close False
            .Range("D6").Value = Left(fileName, InStrRev(fileName, ".") - 1)
            Application.ScreenUpdating = True
        Else
            MsgBox "No files matching '" & matchFile & "' exist in " & folder, vbInformation
        End If
    End With

End Sub

Hi John_w

I have just tested the code and it works beautifully exactly what i needed spot on, thank you so much my friend i very much appreciate the help.

Thank you once again

Just one thing if there is 2 files named

Name 1 15.10.2023 11.05
Name 1 15.10.2023 14.05

How can I get it to pull only the latest file which would be

Name 1 15.10.2023 14.05

 

[John_w]

How can I get it to pull only the latest file

Public Sub Import_Partial_File_Name_Latest_Workbook()
    
    Dim folder As String, matchFile As String, fileName As String, latestFileName As String
    Dim fileDate As Date, latestFileNameDate As Date
    Dim parts As Variant
    Dim wb As Workbook
    
    folder = "C:\path\to\Test\"    'CHANGE THIS PATH
    
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    
    With ActiveSheet
        matchFile = .Range("C6").Value & "*.xls*"
        latestFileName = ""
        latestFileNameDate = 0
        fileName = Dir(folder & matchFile)
        While fileName <> vbNullString
            parts = Split(Left(fileName, InStrRev(fileName, ".") - 1), " ")
            If UBound(parts) >= 2 Then
                fileDate = CDate(Replace(parts(UBound(parts) - 1), ".", "/")) + TimeValue(parts(UBound(parts)))
                If fileDate > latestFileNameDate Then
                    latestFileName = fileName
                    latestFileNameDate = fileDate
                End If
            End If
            fileName = Dir
        Wend
        If latestFileName <> "" Then
            Application.ScreenUpdating = False
            Set wb = Workbooks.Open(folder & latestFileName)
            wb.Worksheets(1).UsedRange.Offset(1).Copy .Range("H7")
            wb.Close False
            .Range("D6").Value = Left(latestFileName, InStrRev(latestFileName, ".") - 1)
            Application.ScreenUpdating = True
        Else
            MsgBox "No files matching '" & matchFile & "' exist in " & folder, vbInformation
        End If
    End With

End Sub

 

[Dippy001]

Public Sub Import_Partial_File_Name_Latest_Workbook()
   
    Dim folder As String, matchFile As String, fileName As String, latestFileName As String
    Dim fileDate As Date, latestFileNameDate As Date
    Dim parts As Variant
    Dim wb As Workbook
   
    folder = "C:\path\to\Test\"    'CHANGE THIS PATH
   
    If Right(folder, 1) <> "\" Then folder = folder & "\"
   
    With ActiveSheet
        matchFile = .Range("C6").Value & "*.xls*"
        latestFileName = ""
        latestFileNameDate = 0
        fileName = Dir(folder & matchFile)
        While fileName <> vbNullString
            parts = Split(Left(fileName, InStrRev(fileName, ".") - 1), " ")
            If UBound(parts) >= 2 Then
                fileDate = CDate(Replace(parts(UBound(parts) - 1), ".", "/")) + TimeValue(parts(UBound(parts)))
                If fileDate > latestFileNameDate Then
                    latestFileName = fileName
                    latestFileNameDate = fileDate
                End If
            End If
            fileName = Dir
        Wend
        If latestFileName <> "" Then
            Application.ScreenUpdating = False
            Set wb = Workbooks.Open(folder & latestFileName)
            wb.Worksheets(1).UsedRange.Offset(1).Copy .Range("H7")
            wb.Close False
            .Range("D6").Value = Left(latestFileName, InStrRev(latestFileName, ".") - 1)
            Application.ScreenUpdating = True
        Else
            MsgBox "No files matching '" & matchFile & "' exist in " & folder, vbInformation
        End If
    End With

End Sub

Hi

Is it possible to put the data in a specific sheet name e.g Sheet1 and then the file name to Sheet2?

 

[Dippy001]

Public Sub Import_Partial_File_Name_Latest_Workbook()
   
    Dim folder As String, matchFile As String, fileName As String, latestFileName As String
    Dim fileDate As Date, latestFileNameDate As Date
    Dim parts As Variant
    Dim wb As Workbook
   
    folder = "C:\path\to\Test\"    'CHANGE THIS PATH
   
    If Right(folder, 1) <> "\" Then folder = folder & "\"
   
    With ActiveSheet
        matchFile = .Range("C6").Value & "*.xls*"
        latestFileName = ""
        latestFileNameDate = 0
        fileName = Dir(folder & matchFile)
        While fileName <> vbNullString
            parts = Split(Left(fileName, InStrRev(fileName, ".") - 1), " ")
            If UBound(parts) >= 2 Then
                fileDate = CDate(Replace(parts(UBound(parts) - 1), ".", "/")) + TimeValue(parts(UBound(parts)))
                If fileDate > latestFileNameDate Then
                    latestFileName = fileName
                    latestFileNameDate = fileDate
                End If
            End If
            fileName = Dir
        Wend
        If latestFileName <> "" Then
            Application.ScreenUpdating = False
            Set wb = Workbooks.Open(folder & latestFileName)
            wb.Worksheets(1).UsedRange.Offset(1).Copy .Range("H7")
            wb.Close False
            .Range("D6").Value = Left(latestFileName, InStrRev(latestFileName, ".") - 1)
            Application.ScreenUpdating = True
        Else
            MsgBox "No files matching '" & matchFile & "' exist in " & folder, vbInformation
        End If
    End With

End Sub

Hi Jon

Hi

Is it possible to put the data in a specific sheet name e.g Sheet1 and then the file name to Sheet2?

 

[John_w]

Is it possible to put the data in a specific sheet name e.g Sheet1 and then the file name to Sheet2?

If that's the only changes and the partial file name is still read from C6 on the active sheet:

wb.Worksheets(1).UsedRange.Offset(1).Copy ThisWorkbook.Worksheets("Sheet1").Range("H7")

and:

ThisWorkbook.Worksheets("Sheet2").Range("D6").Value = Left(latestFileName, InStrRev(latestFileName, ".") - 1)