Combiner 2 codes en 1

Question

Bonjour, j'ai un code existant et une solution pour l'améliorer mais je ne vois pas comment l'incorporer dans le code existant !

Une âme charitable pourrait m'aider ????

Code de base :

Private Sub BTN1_Click()

    Dim CheminFichier As String
    Dim FeuilleSource As Worksheet
    Dim TableauDestination As ListObject
    Dim DerniereLigneSource As Long

    ' Désactive la mise à jour de l'écran pour améliorer les performances
    Application.ScreenUpdating = False

    ' Ouvre la boîte de dialogue pour sélectionner le fichier source
    CheminFichier = Application.GetOpenFilename("Fichiers Excel (*.xls; *.xlsx), *.xls; *.xlsx")

    ' Vérifie si un fichier a été sélectionné
    If CheminFichier = "Faux" Then
        MsgBox "Aucun fichier sélectionné. L'opération a été annulée.", vbExclamation
        Exit Sub
    End If

    ' Définit la feuille de calcul source
    Set FeuilleSource = Workbooks.Open(CheminFichier).Worksheets(1) ' Vous pouvez ajuster le numéro de la feuille si nécessaire

    ' Définit le tableau de destination
    On Error Resume Next
    Set TableauDestination = ThisWorkbook.Sheets("Calcul").ListObjects("TBL_HSTS") ' Assurez-vous que la feuille et le tableau sont correctement nommés
    On Error GoTo 0

    ' Vérifie si le tableau de destination existe
    If Not TableauDestination Is Nothing Then
        ' Trouve la dernière ligne de la colonne A dans la feuille source
        DerniereLigneSource = FeuilleSource.Cells(FeuilleSource.Rows.Count, "A").End(xlUp).Row

        ' Copie les données de la colonne A, B, C et D de la feuille source vers le tableau de destination
        If DerniereLigneSource >= 2 Then ' Vérifie s'il y a au moins 1 ligne de données (à partir de la ligne 2 de la source)
            TableauDestination.ListRows.Add
            FeuilleSource.Range("A2:C" & DerniereLigneSource).Copy TableauDestination.ListColumns(1).DataBodyRange
            MsgBox "Données copiées avec succès!", vbInformation
        Else
            MsgBox "La feuille source ne contient pas de données à copier.", vbExclamation
        End If
    Else
        MsgBox "Le tableau de destination n'a pas été trouvé dans la feuille 'Calcul'.", vbExclamation
    End If

    ' Ferme le fichier source sans enregistrer les modifications
    Workbooks.Open(CheminFichier).Close SaveChanges:=False
End Sub

Code à incorporer :

Sub Extraire6CaracteresAvantExtension()

    Dim nomFichier As String
    Dim nomFichierSansExtension As String
    Dim caracteres As String
    Dim CheminFichier As String

    With Application.FileDialog(msoFileDialogFilePicker)

        If .Show = -1 Then ' Si l'utilisateur clique sur Ouvrir
            CheminFichier = .SelectedItems(1)
        Else
            Exit Sub ' L'utilisateur a annulé la sélection
        End If
    End With

    ' Extraire le nom du fichier sans le chemin d'accès
    nomFichier = Right(CheminFichier, Len(CheminFichier) - InStrRev(CheminFichier, Application.PathSeparator))

    ' Supprimez l'extension du nom de fichier
    nomFichierSansExtension = Left(nomFichier, InStrRev(nomFichier, ".") - 1)

    ' Extrait les 6 caractères précédant l'extension
    If Len(nomFichierSansExtension) >= 6 Then
        caracteres = Right(nomFichierSansExtension, 6)
    End If

    ' Affichez les 6 caractères dans la cellule A1
    Range("A1") = caracteres
End Sub

Merci d'avance à ceux qui pourrons m'aider.

François

h2so4 · Accepted Answer

Sur base de ma boule de cristal, voici Private Sub BTN1_Click() Dim CheminFichier As String Dim nomFichier As String Dim nomFichierSansExtension As String Dim caracteres As String Dim FeuilleSource As Worksheet Dim TableauDestination As ListObject Dim DerniereLigneSource As Long ' Désactive la mise à jour de l'écran pour améliorer les performances Application.ScreenUpdating = False ' Ouvre la boîte de dialogue pour sélectionner le fichier source With Application.FileDialog(msoFileDialogFilePicker) If .Show = -1 Then ' Si l'utilisateur clique sur Ouvrir CheminFichier = .SelectedItems(1) Else Exit Sub ' L'utilisateur a annulé la sélection End If End With ' Extraire le nom du fichier sans le chemin d'accès nomFichier = Right(CheminFichier, Len(CheminFichier) - InStrRev(CheminFichier, Application.PathSeparator)) ' Supprimez l'extension du nom de fichier nomFichierSansExtension = Left(nomFichier, InStrRev(nomFichier, ".") - 1) ' Extrait les 6 caractères précédant l'extension If Len(nomFichierSansExtension) &gt;= 6 Then caracteres = Right(nomFichierSansExtension, 6) End If ' Affichez les 6 caractères dans la cellule A1 Range("A1") = caracteres ' Définit la feuille de calcul source Set FeuilleSource = Workbooks.Open(CheminFichier).Worksheets(1) ' Vous pouvez ajuster le numéro de la feuille si nécessaire ' Définit le tableau de destination On Error Resume Next Set TableauDestination = ThisWorkbook.Sheets("Calcul").ListObjects("TBL_HSTS") ' Assurez-vous que la feuille et le tableau sont correctement nommés On Error GoTo 0 ' Vérifie si le tableau de destination existe If Not TableauDestination Is Nothing Then ' Trouve la dernière ligne de la colonne A dans la feuille source DerniereLigneSource = FeuilleSource.Cells(FeuilleSource.Rows.Count, "A").End(xlUp).Row ' Copie les données de la colonne A, B, C et D de la feuille source vers le tableau de destination If DerniereLigneSource &gt;= 2 Then ' Vérifie s'il y a au moins 1 ligne de données (à partir de la ligne 2 de la source) TableauDestination.ListRows.Add FeuilleSource.Range("A2:C" & DerniereLigneSource).Copy TableauDestination.ListColumns(1).DataBodyRange MsgBox "Données copiées avec succès!", vbInformation Else MsgBox "La feuille source ne contient pas de données à copier.", vbExclamation End If Else MsgBox "Le tableau de destination n'a pas été trouvé dans la feuille 'Calcul'.", vbExclamation End If ' Ferme le fichier source sans enregistrer les modifications Workbooks.Open(CheminFichier).Close SaveChanges:=False End Sub...