Help to brown to folder and load file name then check if string in filename exist

[sbv1986]

Hi all
I have folder with a lot files like: xxxxxx-yyyyyyyy-zzzzzzzz-wwwww-aa-b-cc with extension: .xlsx .xlx .rpt .doc .docx
Please help me with macro VBA to do that:
1. Brown to folder and get all files full name include extension: .xlsx .xlx .rpt to sheets("data") begin from range ("A2")
2. Split all file name from column(A) to column B,C,D,E,F,G,H,I for each dash "-"

The result like this, I examble 03 row but realyty rows defend on the file name in folder from 200 to 500 files each month:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]xxxxx-yyyyyyyy-zzzzzzzz-wwwww-aa-b-cc.xlsx[/TD]
[TD]xxxxxx[/TD]
[TD]yyyyyyyy[/TD]
[TD]zzzzzzzz[/TD]
[TD]wwwwww[/TD]
[TD]aa[/TD]
[TD]b[/TD]
[TD]cc[/TD]
[TD]xlsx[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]xxxxxx-yyyyyyyy-zzzzzzzz-wwwww-aa-b-cc.xls[/TD]
[TD]xxxxxx[/TD]
[TD]yyyyyyyy[/TD]
[TD]zzzzzzzz[/TD]
[TD]wwwwww[/TD]
[TD]aa[/TD]
[TD]b[/TD]
[TD]cc[/TD]
[TD]xls[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]xxxxxx-yyyyyyyy-zzzzzzzz-wwwww-aa-b-cc.rpt[/TD]
[TD]xxxxxx[/TD]
[TD]yyyyyyyy[/TD]
[TD]zzzzzzzz[/TD]
[TD]wwwwww[/TD]
[TD]aa[/TD]
[TD]b[/TD]
[TD]cc[/TD]
[TD]rpt[/TD]
[/TR]
</tbody>[/TABLE]

Thanks in advance.

 

[alansidman]

On the data tab, use text to columns function. Delimiter is dash.

 

[sbv1986]

On the data tab, use text to columns function. Delimiter is dash.

Thanks for your respond but table above in #1 is my result.
All files name i want to get in a folder, not yet in column as you see.

 

[Sequoyah]

Hi sbv1986,
try this:

Sub ListAllFilesInAllFolders3()
    
    Dim MyPath As String, MyFolderName As String, MyFileName As String, str As String
    Dim i As Integer, j As Integer, k As Integer, F As Boolean
    Dim lposition As Integer, Length As Integer, lastRow As Integer
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet
    Dim Key
    Dim FullName As Variant
    
    Application.ScreenUpdating = False
    Set MySheet = Sheets("data")
    
    On Error Resume Next
    
'************************
'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub
        
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
    
'************************
'List all folders
    
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
    
'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        
        Do While MyFileName <> ""
            AllFiles.Add (MyFileName), ""
            
            MyFileName = Dir
        Loop
    Next
    
   MySheet.Activate
    
    [A2].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    
    lastRow = MySheet.Range("A" & Rows.Count).End(xlUp).Row
    
    For j = 2 To lastRow
        str = Range("A" & j).Value
        lposition = InStr(str, ".") - 1
        FullName = Split(Left(str, lposition), "-")
        For k = 0 To UBound(FullName)
            Cells(j, k + 2).Value = FullName(k)
            Length = Len(str)
            Cells(j, "I").Value = Right(str, Length - lposition - 1)
            
            Next k
            Next j
            
            Columns("A:I").AutoFit
                         
            Set AllFolders = Nothing
            Set AllFiles = Nothing
            
            Application.ScreenUpdating = True
            
        End Sub

 

[sbv1986]

Thanks @Sequoyah
Code work but yyyyyyyy or zzzzzzzz or wwwwwwww will lose all character with 0 ahead.
examble yyyyyyyy = 00012345 => the result only have 12345.

So do you have any solution format as text when code run?

 

[Sequoyah]

Hi,
add after the line

 MySheet.Activate

this code:

Columns("A:I").NumberFormat = "@"

 

[sbv1986]

Hi,
add after the line

 MySheet.Activate

this code:

Columns("A:I").NumberFormat = "@"

Thanks again, code working well.

P/S: This mean value auto format as number so if I want I can change another format as your suggess?

 

[Sequoyah]

You're welcome. Thanks for the feedback.


NumberFormat = "@" sets cell format as text.