Need a macro to keep track of files in different folders

andreasmj

New Member
Joined
Nov 22, 2011
Messages
13
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
 

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

b.downey

Active Member
Joined
Oct 16, 2011
Messages
484
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

Active Member
Joined
Oct 16, 2011
Messages
484
Ok... This was a bit more difficult that I thought, but I was able to get it working:

Code:
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

New Member
Joined
Nov 22, 2011
Messages
13
Impressive!!:pray:

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
 

Watch MrExcel Video

Forum statistics

Threads
1,122,521
Messages
5,596,650
Members
414,083
Latest member
Mrsash

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top