Application.GetOpenFilename

Bonjour à toutes et à tous,
Je souhaiterai obtenir votre aide sur mon problème :
Je dois réaliser une application VBA me permettant de sélectionner des fichiers et faire une copie du fichier sélection selon des conditions
Le départ du Code fonctionne très bien, une boîte de dialogue s'ouvre, je sélectionne le fichier , mais la copie ne s'effectue pas.
Je vous joins mon code

Private Sub CommandButton1_Click()
Dim objFSO As Object
Dim i As Byte
ChDrive (ThisWorkbook.Path)
ChDir (ThisWorkbook.Path & "\")
fichs = Application.GetOpenFilename(MultiSelect:=True)

If IsArray(fichs) = False Then Exit Sub
nbf = UBound(fichs)
For n = 1 To nbf
    nom = nom & "-" & fichs(n)
Next
Me.ch9 = nom
Me.ch1 = Right(nom, Len(nom) - InStrRev(nom, "\"))
Me.ch11 = Format(FileDateTime(fichs(1)), "dd/mm/yyyy")

    Dim DosDestination1 As String, DosDestination2 As String, DosDestination3 As String, DosDestination4 As String
    DosDestination1 = ThisWorkbook.Path & "\DOS_NOTES\"
    DosDestination2 = ThisWorkbook.Path & "\DOS_INSTRUCTIONS\"
    DosDestination3 = ThisWorkbook.Path & "\DOS_PROCEDURES\"
    DosDestination3 = ThisWorkbook.Path & "\DOS_CAS_ESPACES\"

Set objFSO = CreateObject("Scripting.FileSystemObject")

 If Me.ch6.Value = "DOS_NOTES" Then
objFSO.CopyFile fichs.SelectedItems(i), DosDestination1
End If
If Me.ch6.Value = "DOS_INSTRUCTIONS" Then
objFSO.CopyFile fichs.SelectedItems(i), DosDestination2
End If
If Me.ch6.Value = "DOS_PROCEDURES" Then
objFSO.CopyFile fichs.SelectedItems(i), DosDestination3
End If
If Me.ch6.Value = "DOS_CAS_ESPACES" Then
objFSO.CopyFile fichs.SelectedItems(i), DosDestination4

End If

End Sub

Merci d'avance

fichs(n) !! peut-être on peut déplacer le "select case" dehors le "For...Next"-loop

Private Sub CommandButton1_Click()
     Dim Fichs

     ChDrive (ThisWorkbook.Path)
     ChDir (ThisWorkbook.Path & "\")
     Fichs = Application.GetOpenFilename(MultiSelect:=True)
     If IsArray(Fichs) = False Then Exit Sub

     For n = 1 To UBound(Fichs)
          Select Case Me.ch6.Value
               Case "DOS_NOTES", "DOS_INSTRUCTIONS", "DOS_PROCEDURES", "DOS_CAS_ESPACES"
                    CreateObject("Scripting.FileSystemObject").CopyFile Fichs(n), ThisWorkbook.Path & "\" & me.ch6.Value & "\"
          End Select
     Next

End Sub

Bonjour

j'ai essayé avec ce code mais sans succès

Private Sub CommandButton1_Click()
Dim objFSO As Object
Dim i As Byte
ChDrive (ThisWorkbook.Path)
ChDir (ThisWorkbook.Path & "\")
fichs = Application.GetOpenFilename(MultiSelect:=True)

If IsArray(fichs) = False Then Exit Sub
'nbf = UBound(fichs)
For n = 1 To UBound(fichs)
    nom = nom & "-" & fichs(n)
     Select Case Me.ch6.Value
               Case "DOS_NOTES", "DOS_INSTRUCTIONS", "DOS_PROCEDURES", "DOS_CAS_ESPACES"
                    CreateObject("Scripting.FileSystemObject").CopyFile fichs(n), ThisWorkbook.Path & "\" & Me.ch6.Value & "\"
          End Select
Next
Me.ch9 = nom
Me.ch1 = Right(nom, Len(nom) - InStrRev(nom, "\"))
Me.ch11 = Format(FileDateTime(fichs(1)), "dd/mm/yyyy")

End Sub

ces subdirectories, ils existent ???

Sub Teste()

     Dim OldDir, n, ch6 As String

     If ThisWorkbook.Path = "" Then MsgBox "fatal error": Exit Sub
     ChDrive (ThisWorkbook.Path)
     ChDir (ThisWorkbook.Path & "\")
     OldDir = CurDir

     fichs = Application.GetOpenFilename(MultiSelect:=True)

     If IsArray(fichs) = False Then Exit Sub

     ch6 = "DOS_PROCEDURES"     'pour tester par exemple celui-ci  <----------------------------------
     Select Case ch6
          Case "DOS_NOTES", "DOS_INSTRUCTIONS", "DOS_PROCEDURES", "DOS_CAS_ESPACES"

               s = ThisWorkbook.Path & "\" & ch6       'pour etre sur que ce directory existe
               On Error Resume Next
               ChDir s     'pour etre sur que ce directory existe
               If CurDir <> s Then MsgBox "directory n'existait pas ", vbInformation: MkDir s
               ChDir s     'pour etre sur que ce directory existe
               If CurDir <> s Then MsgBox "directory n'existait pas ", vbCritical: Exit Sub

               ChDir OldDir
               On Error GoTo 0

               For n = 1 To UBound(fichs)
                    CreateObject("Scripting.FileSystemObject").CopyFile fichs(n), ThisWorkbook.Path & "\" & ch6 & "\"
               Next
     End Select
End Sub

oui ces répertoires existent il sont dans le répertoire parent "E:\BASE_DOCUMENTATIONS_DP\"

toujours le même problème impossible de déplacer le fichier ci dessus mon fichier pour plus d'information

ma reaction de 10:43 est sans userform et avec un CH6 as string = "DOS_PROCEDURES".

Lles fichiers sélectionnés seront sauvegardés dans de subdirectories du path de l'active workbook.

Donc l'active fichier est-il sauvegardé dans ce "E:\BASE_DOCUMENTATIONS_DP\" ou ailleurs ?

oui il est sauvegardé dans "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\"

oui il est sauvegardé dans "E:\BASE_DOCUMENTATIONS_DP\DOS_PROCEDURES\"

re,

comme je n'avais pas votre userform, ch6 était un string chez moi, mais c'est un combobox chez vous. J'ai ajouté un msgbox à la fin, qui explique ce qui se passe. Vous pouvez l'effacer plus tard .

Bonjour,

C'est nickel, ça fonctionne à merveille !

Merci encore pour votre aide.

Salutations