Need a macro to keep track of files in different folders

[andreasmj]

I am working for a company where we send out a lot of documents to suppliers and etc. All of this is saved in folders like (C:\Transmittals\Company name\transmittalXXX\transmittalXXX.pdf). As this becomes a lot of work typing in manually, I want to create a macro that does it for me.
However, it's been several years since last time I did any programming and now all I can get is "File name" and "Date created". Another problem is that within these folders, the drawings/documents sent with the transmittal are there as well. I don't want these to be listed in the excel sheet.

Can anyone help me with this?

The information I want in the excel sheet is:
Column A: Company name
Column B: Date Created
Column C: Transmittal number(XXX)
Column D: Transmittal name (their filename will be (0183-XXX "company name") without file extension.

and if possible
Column E, F, G, H...: Other documents in the folder, but without the file extension.

The script will be repeated many times so including a "clear" command in the beginning might be a good idea.

Help would be much appreciated!!!

Best regards
Andreas

 

[b.downey]

If I understand correctly, the following SpreadSheet fields are derived from the PDF Files names?
-Transmittal Number (First 8 Chars of the file Name)
-Company Name (9th char till the file extention '.PDF')
-Transmittal Name is really just the file name minus the ".PDF" extention (


Is this correct?

 

[b.downey]

Ok... This was a bit more difficult that I thought, but I was able to get it working:

Option Explicit
Dim ws As Worksheet
Dim RowNo As Long
Sub Extract()
    Dim fd As FileDialog
    Dim strDir As String
    Dim s As String
    Dim CoPath() As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Transactions file to import"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    
    Set ws = ThisWorkbook.Worksheets(1)
    ws.Cells.ClearContents
    ws.Range("A1") = "Company"
    ws.Range("B1") = "Modify Date"
    ws.Range("C1") = "No"
    ws.Range("D1") = "FileName"
    RowNo = 2
    
    strDir = fd.SelectedItems(1)
    Set fd = Nothing
    s = Dir(strDir & "\*.*", vbDirectory)
    ReDim CoPath(0)
    
    'Loop thru the base directory to determine Company directories
    Do While s <> ""
        If GetAttr(strDir & "\" & s) And vbDirectory Then
            'This is a Company Directory
            Select Case s
                Case ".", ".."
                    'Skip
                Case Else
                    ReDim Preserve CoPath(UBound(CoPath) + 1)
                    CoPath(UBound(CoPath)) = strDir & "\" & s
            End Select
        End If
        s = Dir
    Loop
    
    Dim I As Integer
    For I = 1 To UBound(CoPath)
        Call ProcessCoSubDir(CoPath(I))
    Next I
End Sub
Function ProcessCoSubDir(ByVal BasePath As String)
    Dim s As String
    Dim subdir() As String
    'This Directory is the first level and contains The Transmittal subdirectories
    ReDim subdir(0)
    s = Dir(BasePath & "\*.*", vbDirectory)
    
    'Loop thru the base directory to determine Files
    Do While s <> ""
            Select Case s
                Case ".", ".."
                    'Skip
                Case Else
                    ReDim Preserve subdir(UBound(subdir) + 1)
                    subdir(UBound(subdir)) = BasePath & "\" & s
            End Select
                
        s = Dir
    Loop
    
    Dim I As Integer
    For I = 1 To UBound(subdir)
        ProcessTranSubDir (subdir(I))
    Next I
End Function
Function ProcessTranSubDir(ByVal BasePath As String)
    Dim s As String
    Dim subdir() As String
    
    'Debug.Print BasePath, FileDateTime(BasePath)
    
    ReDim subdir(0)
    s = Dir(BasePath & "\*.pdf*")
    
    'Loop thru the base directory to determine Transmittle Files
    Do While s <> ""
        If GetAttr(BasePath & "\" & s) Then
            'This is a Company Directory
            Select Case s
                Case ".", ".."
                    'Skip
                Case Else
                    ReDim Preserve subdir(UBound(subdir) + 1)
                    subdir(UBound(subdir)) = BasePath & "\" & s
            End Select
                
        End If
        s = Dir
    Loop
    
    Dim I As Integer
    For I = 1 To UBound(subdir)
        Call ProcessFile(subdir(I))
    Next I
End Function
Function ProcessFile(ByVal strFile As String)
    Dim v As Variant
    Dim cnt As Integer
    
    Dim FName As String
    
    Debug.Print strFile
    v = Split(strFile, "\")
    cnt = UBound(v)
    ws.Cells(RowNo, "A") = v(cnt - 2)
    ws.Cells(RowNo, "B") = FileDateTime(strFile)
    
    FName = v(cnt)
    FName = Mid$(FName, 1, Len(FName) - 4)
    
    ws.Cells(RowNo, "C") = Mid$(FName, 6, 4)
    ws.Cells(RowNo, "D") = FName
    RowNo = RowNo + 1
    
End Function

 

[andreasmj]

Impressive!!ray:

I will have to customize the layout a bit, but thank you so much for writing the code for me! You just saved my day. I've spent the last two days typing in 1600 rows manually and I was just going to start up the same process again.

Lifesaver!

Andreas

 

[b.downey]

Thanks Andreas. Glad I could help!

Bill