Copying file names-CodePudding

I have the following code, but am looking to change it so the output only provides the first part of the file name. The file names are in the following format. ZipCode_Name_Date. I only want the part of the name which states the Zipcode to print out.

Option Explicit

Sub GetFileDetails()
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.Folder
    Dim objFile As Scripting.File
    Dim nextRow As Long

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder("")
    
    nextRow = Cells(Rows.Count, 1).End(xlUp).Row   1
    
    For Each objFile In objFolder.Files
        Cells(nextRow, 1) = objFile.Name
        nextRow = nextRow   1
    Next
End Sub

CodePudding user response：

Please, replace Cells(nextRow, 1) = objFile.Name with Cells(nextRow, 1) = Split(objFile.Name, "_")(0).

CodePudding user response：

Extract FileParts

If you write it as a function...

Option Explicit

Function GetFirstFileNamePart( _
    ByVal FolderPath As String, _
    ByVal FilePartsDelimiter As String) _
As Variant

    Dim fsoFolder As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(FolderPath) Then Exit Function
        Set fsoFolder = .GetFolder(FolderPath)
    End With
    
    Dim fCount As Long: fCount = fsoFolder.Files.Count
    If fCount = 0 Then Exit Function
    
    Dim Data As Variant: ReDim Data(1 To fCount, 1 To 1)
    
    Dim fsoFile As Object
    Dim n As Long
    
    For Each fsoFile In fsoFolder.Files
        n = n   1
        ' This is the place to modify what to return.
        ' 0 means the part before the first found delimiter.
        Data(n, 1) = Split(fsoFile.Name, FilePartsDelimiter)(0)
    Next fsoFile
    
    GetFirstFileNamePart = Data
    
End Function

... you can easily utilize it in the calling procedure (adjust the constants):

Sub GetFirstFileNamePartTEST()
    
    ' Constants
    Const FilePartsDelimiter As String = "_"
    Dim FolderPath As String
    FolderPath = Environ("OneDrive") & "\Documents\"
    Const dCol As String = "A"
    
    ' Using the function, write the data to a 2D one-based one-column array.
    Dim Data As Variant
    Data = GetFirstFileNamePart(FolderPath, FilePartsDelimiter)
    
    ' Validate.
    If IsEmpty(Data) Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    ' Write the data to the range.
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    Dim dCell As Range
    Set dCell = ws.Cells(ws.Rows.Count, dCol).End(xlUp).Offset(1)
    Dim drg As Range: Set drg = dCell.Resize(UBound(Data, 1), UBound(Data, 2))
    drg.Value = Data
        
    MsgBox "First filename parts copied.", vbInformation
        
End Sub