Ajout d'une inbox dans un code VBA existant

Samedi à 23:32

Bonjour,

Quelqu'un saurait-il ajouter une inbox permettant de choisir le dossier de destination au lieu d'avoir un chemin fixe dans le code :

Sub SplitDataByColToWorkbooks()
    ' Updateby Extendoffice
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWS As Workbook
    Dim savePath As String
    ' Set the directory to save new workbooks
    savePath = "C:\Users\AddinsVM001\Desktop\multiple files\" ' Modify this path as needed
    Application.DisplayAlerts = False
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.Address(False, False)
    titlerow = xTRg.Row
    ws.Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Cells(1, ws.Columns.Count), Unique:=True
    myarr = Application.Transpose(ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).Value)
    ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).ClearContents
    For i = 2 To UBound(myarr)
        Set xWS = Workbooks.Add
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i)
        ws.Range("A" & titlerow & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        xWS.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        xWS.SaveAs Filename:=savePath & myarr(i) & ".xlsx"

        xWS.Close SaveChanges:=False
    Next i
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    ws.Activate
End Sub

Merci!

Hier à 01:35

Bonsoir le fil,

Cpabanal, Ajouter un module et collez-y ce code :

Option Explicit

'----------------- ENUMERATION FOR READANDWRITEPARAM
Public Enum vaFileDialogFilterType
    AllFile
    ExcelFile
    HtmlFile
    ImagesFile
    PdfFile
End Enum

'@Description "Open the folder selector, and save the feedback in the settings."
Public Function GetSavePath(Optional ByVal InitialPath As String = vbNullString, _
                            Optional ByVal FileDialogType As Office.MsoFileDialogType = msoFileDialogFolderPicker, _
                            Optional ByVal FilterType As vaFileDialogFilterType = AllFile _
                            ) As String

    On Error GoTo Catch

    Dim localFileDialog As Office.FileDialog
    Set localFileDialog = Application.FileDialog(FileDialogType)
    With localFileDialog
        .Filters.Clear
        .AllowMultiSelect = False

        If FileDialogType = msoFileDialogFolderPicker Then
            .title = "Sélectionnez un dossier..."
        Else
            .title = "Sélectionnez le fichier de destination."
            Select Case FilterType
                Case AllFile
                    .Filters.Add "Tous les fichiers", "*.*", 1
                Case ExcelFile
                    .Filters.Add "Documents Excel", "*.xls; *.xlsx; *.xlsm; *.xlst; *.xlsb; *.csv", 1
                Case ImagesFile
                    .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.png; *.bmp", 1
                Case HtmlFile
                    .Filters.Add "Documents Htm", "*.Htm; *.Html", 1
                Case PdfFile
                    .Filters.Add "Fichiers Adobe PDF", "*.pdf; *.pdx; *.bpdx; *.fcdt; *.fdf", 1
            End Select

        End If

        .InitialView = msoFileDialogViewList
        If InitialPath = vbNullString Then
            .InitialFileName = ThisWorkbook.Path
        Else
            .InitialFileName = IIf(Right$(.InitialFileName, 1) <> "\", "\", vbNullString)
        End If

        If .Show Then
            GetSavePath = .SelectedItems(1)
        Else
            MsgBox "Commande annulée par l'utilisateur!"
            GetSavePath = vbNullString
        End If
    End With

Finally:
    ' // Cleaning of the memory.
    If Not localFileDialog Is Nothing Then Set localFileDialog = Nothing
    Exit Function

Catch:
    MsgBox "Erreur " & Err.Number & " (" & Err.Description & ")" & vbCrLf & _
           "Dans la procédure 'ReadAndWriteParam' du Module 'modFunctions'"
    Resume Finally

End Function

Vous pourrez ensuite changer l'appel dans votre procédure comme ceci :

Sub SplitDataByColToWorkbooks()
    '// Set the directory to save new workbooks
    On Error GoTo Catch

    '// ------------ L'APPEL SE FAIT ICI ------------
    Dim savePath As String
    savePath = GetSavePath(InitialPath:="C:\Users\AddinsVM001\Desktop\multiple files", _
                           FileDialogType:=msoFileDialogFolderPicker) ' Modify this path as needed

    Application.DisplayAlerts = False

    Dim xTRg  As Range
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub

    Dim xVRg  As Range
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub

    Dim vcol  As Variant
    vcol = xVRg.Column

    Dim ws    As Worksheet
    Set ws = xTRg.Worksheet

    Dim lr    As Long
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

    Dim title As String
    title = xTRg.Address(False, False)

    Dim titlerow As Integer
    titlerow = xTRg.Row
    ws.Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Cells(1, ws.Columns.Count), Unique:=True

    Dim myarr As Variant
    myarr = Application.Transpose(ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).Value)
    ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).ClearContents

    Dim i     As Integer
    For i = 2 To UBound(myarr)
        Dim xWS As Workbook
        Set xWS = Workbooks.Add
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i)
        ws.Range("A" & titlerow & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        xWS.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        xWS.SaveAs Filename:=savePath & myarr(i) & ".xlsx"

        xWS.Close SaveChanges:=False
    Next i
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    ws.Activate

Finally:
    Application.DisplayAlerts = True
    Exit Sub

Catch:
    If Err.Number > 0 Then
        ' // Do something.
        MsgBox "Oupss... Nous avons rencontré une erreur : " & Err.Number & _
               " (" & Err.Description & ") dans la procédure SplitDataByColToWorkbooks du Module Module1"

        Resume Finally
    End If
End Sub

Quand vous utilisez 'Application.EnableEvents ou Application.DisplayAlert prenez soin de l'encadrer dans une gestion d'erreur.

Certaines parties du code me paraissent bizarres, mais ça c'est une autre histoire...

Bonne programmation.

Hier à 07:46

Bonjour et merci pour votre réponse rapide, je vais tester ça.

Pour les bizarreries détectées, j'avoue ne pas avoir l'expertise pour les repérer, j'ai récupéré ce code sur un site internet, il correspondait à mon besoin hormis le choix du dossier de destination.

Hier à 13:46

Bonjour le fil,

Bon apparemment mon dernier message n'est pas passé...

En regardant de plus près le code que j'ai fourni, j'ai remarqué un petite boulette sur la ligne : .InitialFileName = IIf(Right$(.InitialFileName, 1) <> "\", "\", vbNullString) gardée tel quel elle renvoie une valeur erronée. De plus les bloc IIf peuvent ne pas fonctionner comme il se doit donc préférez lui un bloc If tout simple. Remplacer la ligne par ce bloc :

        If InitialPath = vbNullString Then
            .InitialFileName = ThisWorkbook.Path & "\"
        Else
            If Right$(InitialPath, 1) = "\" Then
                .InitialFileName = InitialPath
            Else
                .InitialFileName = InitialPath & "\"
            End If
        End If

Vous remarquerez aussi que cette fonction est générique elle est capable de s'adapter à l'ouverture soit d'un fichier soit d'un répertoire. En effet tous les paramètres sont facultatifs, par défaut le sélecteur de répertoire sera sélectionné. Exemple :

Public Sub Test102()
    Dim SavePath As String
    SavePath = GetSavePath '// Ici  c'est le sélecteur de dossier qui sera ouvert.
    If SavePath > vbNullString Then
        '...
        '...
    End If
End Sub

Petites points subsidiaires.
Il est plus rapide et plus normal de tester directement si "xTRg" est à Nothing que de passer par TypeName.

Donc ceci :

    Dim xTRg  As Range
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub

Peut être avantageusement remplacé par cela :

    Dim xVRg  As Range
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If xVRg Is Nothing Then Exit Sub

Pareil pour "xVRg"...

Bonne programmation...

Hier à 17:49

J'ai fait les modifs suggérées, ça fonctionne parfaitement. Merci bcp!

Hier à 18:27

Re,

Cpabanal, n'oubliez pas de marquer le sujet résolu. Et un petit vote fait toujours plaisir...

Rechercher des sujets similaires à "ajout inbox code vba existant"