Grouping files into new folder based on file name

[leo_capri]

I have one folder contains lot of files xlsx & pdf. I need to grouping each files (pdf & xlsx) based on the file name into a new folder. can it runs by macro ?
Kindly help me on this case.
Thank you very much

 

[OaklandJim]

I put together this workbook. I hope that it does what you want.

Option Explicit
Option Base 1

Sub MovePDFsAndExcels()

'   Array holding file names.
    Dim asFilesList() As String
    
'   Count of files found.
    Dim iFilesFound As Long
    
'   File number for looping file names.
    Dim iFile As Long
    
'   Directory into which files will be moved.
    Dim sMoveToFolder As String
    
'   Name of folder containing PDF files.
    Dim sPDFFolderName As String
    
'   Name of folder containing Excel files.
    Dim sExcelFolderName As String
    
    sPDFFolderName = "PDF Files"
    
    sExcelFolderName = "Excel Files"

'   Default folder is the one that "Thisworkbook" is in.
    sMoveToFolder = ThisWorkbook.Path & "\"
    
'   If user specified an alternate folder (in worksheetnamed Control) then use that folder's name.
    With Worksheets("Control")
    
        If .Range("AlternateFolder").Value <> "" _
         Then
         
            sMoveToFolder = .Range("AlternateFolder").Value
            
            If Right(sMoveToFolder, 1) <> "\" Then sMoveToFolder = sMoveToFolder & "\"
            
'           Check alternate folder exists.
            If Not CheckFolderExists(sMoveToFolder) _
             Then
                
'               If alternate folder does not exist then tell user then exit sub.
                MsgBox "The folder named" & Chr(10) & sMoveToFolder & Chr(10) & "does not exist."
                Exit Sub
            End If
         
        End If
    
    End With

'   Fill array with file names
    asFilesList = GetFilesInDir(sMoveToFolder)

'   Get count of files found.
    iFilesFound = UBound(asFilesList)

    For iFile = 1 To iFilesFound

        If UCase(Right(asFilesList(iFile), 3)) = "PDF" _
         Then
         
'           If PDF files directory does not exist then create it.
            If Not CheckFolderExists(sMoveToFolder, sPDFFolderName) Then MkDir (sMoveToFolder & sPDFFolderName)
            
'           Move the PDF file to the PDF files folder.
            Name sMoveToFolder & asFilesList(iFile) As sMoveToFolder & sPDFFolderName & "\" & asFilesList(iFile)
    
        ElseIf UCase(asFilesList(iFile)) Like "*.XLS*" _
         Then
         
'           If Excel files directory does not exist then create it.
            If Not CheckFolderExists(sMoveToFolder, sExcelFolderName) Then MkDir (sMoveToFolder & sExcelFolderName)
            
'           Do not/Cannot move "this workbook" file.
            If asFilesList(iFile) <> ThisWorkbook.Name _
             Then
             
'               Move the Excel file to the Excel files folder.
                Name sMoveToFolder & asFilesList(iFile) As sMoveToFolder & sExcelFolderName & "\" & asFilesList(iFile)
                
            End If
    
        End If
    
    Next iFile

End Sub

Option Explicit

'Based on https://www.automateexcel.com/vba/file-exists/
Function CheckFolderExists(psDir, Optional psFolderName As String = "")

    Dim strFolderName As String
    Dim strFolderExists As String
    
    If Right(psDir, 1) <> "\" Then psDir = psDir & "\"

    If psFolderName <> "" _
     Then
        
        If Right(psFolderName, 1) <> "\" Then psFolderName = psFolderName & "\"
        strFolderName = psDir & psFolderName
    Else
        strFolderName = psDir
    End If
    
    strFolderExists = Dir(strFolderName, vbDirectory)

    If strFolderExists = "" Then
        CheckFolderExists = False
    Else
        CheckFolderExists = True
    End If

End Function

Option Explicit
Option Base 1
'Based on https://stackoverflow.com/questions/31414106/get-list-of-excel-files-in-a-folder-using-vba

'Returns an array containing the file names.

Function GetFilesInDir(ByVal sPath As String, _
    Optional ByVal sFilter As String) As String()

'   Dynamically sized array for file names.
    Dim aFileNames() As String
    ReDim aFileNames(1)

    Dim sFile As String
    Dim nCounter As Long

    If Right(sPath, 1) <> "\" Then
        sPath = sPath & "\"
    End If

    If sFilter = "" Then
        sFilter = "*.*"
    End If

'   Call with path "initializes" the dir function and returns the first file
    sFile = Dir(sPath & sFilter)

    nCounter = 1
    
'   Loop folder until there is no file name returned.
    Do While sFile <> ""

        'store the file name in the array
        aFileNames(nCounter) = sFile

        'subsequent calls without param return next file
        sFile = Dir

        'make sure your array is large enough for another
        nCounter = nCounter + 1
        
        If nCounter > UBound(aFileNames) Then
            'preserve the values and grow by reasonable amount for performance
            ReDim Preserve aFileNames(UBound(aFileNames) + 255)
        End If

    Loop

'   Truncate the array to correct size
    If nCounter < UBound(aFileNames) Then
        ReDim Preserve aFileNames(1 To nCounter)
    End If

'   Return the array of file names.
    GetFilesInDir = aFileNames()

End Function

Option Explicit

Sub SelectFolder()
'PURPOSE: Have User Select a Folder Path and Store it to a variable
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

    Dim FldrPicker As FileDialog
    Dim sMyFolder As String
    
'   Have User Select Folder to Save to with Dialog Box
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
      If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
      sMyFolder = .SelectedItems(1) & "\"
    End With
      
    If CheckFolderExists(sMyFolder) _
     Then
        [Control].Range("AlternateFolder").Value = sMyFolder
    End If

End Sub