excel vba help

[shariq]

hello experts i need your help please understand my problem i have thousand of file with diffrents extention like (jpg.pdf.chrome.outloolk mail) and i want to move them into the folder with the match of first 5 to 6 digit code to the folder.

my file name are like this..
09437 experience letter
04298 experience letter
07897 contract letter
00058 Bsc dgree
CO4298 experience letter
C02142 certificate

my folder name are like this
09437 john
04298 alberto
07897 micheal
00058 christopher
C04298 jackson
C02142 polard

iam try this code but its not working fine this script create new folder with same name of file but i have already created i want just read this code not read full name if file code match with folder code then move file into the folder.
script are given below..


Sub CopyFiles()

'Declare variables
Dim FSO As Object
Dim SourceFolder As Object
Dim DestinationFolder As Object
Dim File As Object

'Set the source and destination folders
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder("c:\users\employee.records\desktop\shariq")
Set DestinationFolder = FSO.GetFolder("D:\employee.records\desktop\back up by immad")

'Loop through all the files in the source folder
For Each File In SourceFolder.Files
'Extract the file name without the extension
Dim FileNameWithoutExtension As String
FileNameWithoutExtension = FSO.GetBaseName(File.Name)

'If a folder with the same name as the file doesn't exist in the destination folder, create it
If Not FSO.FolderExists(DestinationFolder & "\" & FileNameWithoutExtension) Then
Set DestinationSubFolder = FSO.CreateFolder(DestinationFolder & "\" & FileNameWithoutExtension)
Else
'If the folder already exists, set it as the destination folder
Set DestinationSubFolder = FSO.GetFolder(DestinationFolder & "\" & FileNameWithoutExtension)
End If
'Copy the file to the destination folder
File.Copy DestinationSubFolder & "\" & File.Name
Next

End Sub

 

[shariq]

any one please give me a solution

 

[shariq]

any one have a solution of my problem .

 

[HaHoBe]

Hi shariq,

if you take the name of the file (09437 experience letter) and look at the folders in the destination path you will find no match as the folder you are looking for is named 09437 john. So instead of looking for a full match you must look for a partial match.

Maybe try

'modulewide variable to hold either the name of SubFolder or ""
Dim strRet As String
'

Public Sub MrE_1228283_1701C0A()
' https://www.mrexcel.com/board/threads/excel-vba-help.1228283/

  'Declare variables
  Dim objFSO              As Object
  Dim objSrcFold          As Object
  Dim objDestFold         As Object
  Dim objDestSubFold      As Object
  Dim objFile             As Object
  Dim strFN_WoExt         As String
  
  'Set the source and destination folders
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objSrcFold = objFSO.GetFolder("c:\users\employee.records\desktop\shariq")
  Set objDestFold = objFSO.GetFolder("D:\employee.records\desktop\back up by immad")
  
  'Loop through all the files in the source folder
  For Each objFile In objSrcFold.Files
    'Extract the file name without the extension
    strFN_WoExt = objFSO.GetBaseName(objFile.Name)
    'Extract the first part of the FileName until blank
    strFN_WoExt = Left(strFN_WoExt, InStr(strFN_WoExt, " ") - 1)
    
    strRet = ""
    'Search in SubFolders if a match is found
    prcSubFolders objDestFold, strFN_WoExt
    If strRet = "" Then
      'If a folder with the same name as the file doesn't exist in the destination folder, create it
      Set objDestSubFold = objFSO.CreateFolder(objDestFold & "\" & strFN_WoExt)
    Else
      'If the folder already exists, set it as the destination folder
      Set objDestSubFold = objFSO.GetFolder(objDestFold & "\" & strRet)
    End If
    'Copy the file to the destination folder
    objFile.Copy objDestSubFold & "\" & objFile.Name
  Next objFile
  
  Set objDestSubFold = Nothing
  Set objDestFold = Nothing
  Set objSrcFold = Nothing
  Set objFSO = Nothing
End Sub

Private Sub prcSubFolders(objFolder As Object, strPartName As String)
  'search the subfolders of destination path and look for partial match
  Dim objSubFold    As Object
  
  If InStr(1, objFolder.Name, strPartName, vbTextCompare) > 0 Then
    strRet = objFolder.Name
    Exit Sub
  End If
  'loop through the subfolders
  For Each objSubFold In objFolder.Subfolders
    prcSubFolders objSubFold, strPartName
  Next objSubFold
End Sub

Ciao,
Holger

 

[shariq]

not working error show( invalid procedure call or argument)

 

[HaHoBe]

Hi shariq,

be assured I tested the procedures before posting, and it works (we'll see if it does what you want) - there are 2 procedures in the code, you need to copy both into one standard module (as well as the modulewide variable at the top of that module).

Ciao,
Holger

 

[shariq]

iam just copy this code and past the vba and click on run popup window appear invalid procedure cal or arugments.

 

[HaHoBe]

Hi shariq,

as I can't see anything on that small image I uploaded a sample of my workbook MrE_1228283_Sample 230128.xlsm. Please note that you have to download the workbook in order to run the code.

Holger

 

[shariq]

bro please give me a short solution i just want to move file into the folder with same employe code like this 04747 john cena this is folder name 04747 letter file name just read 5 to 6 digit code if match with folder code then move file. please give me short solution iam not expert and english is not my native language . i hope u understand my problem .thanks holger

 

[HaHoBe]

Hi shariq,

maybe try this altered procedure:

Public Sub MrE_1228283_1701C15()
' https://www.mrexcel.com/board/threads/excel-vba-help.1228283/

  'Declare variables
  Dim arr
  Dim lngCnt              As Long
  Dim objFSO              As Object
  Dim objSrcFold          As Object
  Dim objDestFold         As Object
  Dim objDestSubFold      As Object
  Dim objFile             As Object
  Dim strFN_WoExt         As String
  Dim strEntry            As String
  Dim objSubFolder        As Object
  Dim varRet              As Variant
  
  'Set the source and destination folders
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objSrcFold = objFSO.GetFolder("c:\users\employee.records\desktop\shariq")
  Set objDestFold = objFSO.GetFolder("D:\employee.records\desktop\back up by immad")
  
  'Fill an array of folders in destination folder (shortened name and name)
  lngCnt = 0
  ReDim arr(1 To objDestFold.Subfolders.Count, 1 To 2)
  For Each objSubFolder In objDestFold.Subfolders
    lngCnt = lngCnt + 1
    strEntry = objSubFolder.Name
    If InStr(1, strEntry, " ") > 0 Then strEntry = Left(strEntry, InStr(strEntry, " ") - 1)
    arr(lngCnt, 1) = strEntry
    arr(lngCnt, 2) = objSubFolder.Name
  Next objSubFolder
  
  'Loop through all the files in the source folder
  For Each objFile In objSrcFold.Files
    'Extract the file name without the extension
    strFN_WoExt = objFSO.GetBaseName(objFile.Name)
    'Extract the first part of the FileName until blank
    strFN_WoExt = Left(strFN_WoExt, InStr(strFN_WoExt, " ") - 1)
   
    'would not find folder C02142 polard but create new C02142
'    'check if the shortened name is in Array
'    varRet = Application.Match(strFN_WoExt, vLine, 0)
    
    'Loop through array to compare shortnames, if found --> exit
    For lngCnt = LBound(arr, 1) To UBound(arr, 1)
      varRet = CVErr(xlErrNA)
      If arr(lngCnt, 1) = strFN_WoExt Then
        varRet = lngCnt
        Exit For
      End If
    Next lngCnt
    If IsError(varRet) Then
      'If a folder with the same name as the file doesn't exist in the destination folder, create it
      Set objDestSubFold = objFSO.CreateFolder(objDestFold & "\" & strFN_WoExt)
    Else
      'If the folder already exists, set it as the destination folder
      Set objDestSubFold = objFSO.GetFolder(objDestFold & "\" & arr(varRet, 2))
    End If
    'Copy the file to the destination folder
    objFile.Copy objDestSubFold & "\" & objFile.Name
  Next objFile
  
  Erase arr
  Set objDestSubFold = Nothing
  Set objDestFold = Nothing
  Set objSrcFold = Nothing
  Set objFSO = Nothing
End Sub

Ciao,
Holger