Emboiter des colonnes en fonction de la valeur de leurs entête

Question

Bonjour a tous,

Je rencontre un soucis dans mon algo VBA, celui ci fonctionne mais les colonne sont décaler.
Comme indiquer dans le titre j'ai développer un algo VBA qui va ouvrir un fichier B, vérifier les valeurs de ses cellules d'entête et les comparer avec les cellules d'entête d'un autre fichier A(l'algo se trouve dans celui ci). Si les entêtes du fichier B ont le même noms alors je copie et colle les colonnes dans mon fichier A bien entendu je les colles dans la colonne du fichier A qui a le même nom.

Ci dessous le code.

Option Explicit

Sub Fusion()

Application.ScreenUpdating = False

Dim der_ligne1
Dim der_ligne2
Dim dercol1
Dim dercol2
Dim col1
Dim col2
Dim Ncol1
Dim Ncol2
Dim libele As String
Dim libele2 As String
Dim LTR1
Dim LTR2
Dim wb As Workbook
Dim FichierOuvert As Worksheet

Set wb = Workbooks.Open("Nom.Fichier")

der_ligne1 = Workbooks("P1auto.xlsm").Sheets("Performance Source").Cells(Rows.Count, 4).End(xlUp).Row 'définir la dernière ligne utilisée
der_ligne2 = wb.Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row 'définir la dernière ligne utilisée

'determine le nombre de colonnes non vides
dercol1 = Workbooks("P1auto.xlsm").Sheets("Performance Source").Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'définir le dernier numéro de colonne pour arrêter la boucle
dercol2 = wb.Sheets("Feuil1").Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'définir le dernier numéro de colonne pour arrêter la boucle

For col1 = 2 To dercol1
Ncol1 = Cells(1, col1).Column ' renvoi le numéro de colonne trouvée corresponante
libele = CStr(Cells(3, Ncol1))

        LTR1 = Left((Cells(3, Ncol1).Address), 3) 'récupérer uniquement la lettre de l'adresse

'-----------------------------------------------------------------------------boucle 2 --------------------------------------------------------

    For col2 = 3 To dercol2
        Ncol2 = Cells(1, col2).Column ' renvoi le numéro de colonne trouvée corresponante
        libele2 = wb.Sheets("Feuil1").Cells(3, Ncol2)
        If libele = libele2 Then  'CStr(Cells(3, Ncol2)) Then

        LTR2 = Left((Cells(3, Ncol2).Address), 3) 'récupérer uniquement la lettre de l'adresse

        Dim AireSource As Range, CelluleCible As Range

        Set CelluleCible = Workbooks("P1auto.xlsm").Sheets("Performance Source").Range(LTR1 & der_ligne1 + 1) 'définir la cellule vers laquelle coller la plage de données
        Set AireSource = wb.Sheets("Feuil1").Range(LTR2 & "4:" & LTR2 & der_ligne2) ' définir la plage de données à copier

        AireSource.Copy Destination:=CelluleCible 'copie d'une feuille à l'autre

        Set CelluleCible = Nothing 'raz variable
        Set AireSource = Nothing 'raz variable

        GoTo suite  'sortir de la boucle
        End If

    Next

'--------------------------------------------------------------------fin boucle 2 ---------------------------------------------------------------

suite:

Next

MsgBox ("terminé")

End Sub

Le resultat:

Normalement la valeur de la colonne Mois doit se situer a Code D/I

Merci pour votre aide

Curulis · Accepted Answer

Plus facile avec un fichier... pour comprendre pourquoi cela n'allait pas ! - les lignes d'en-têtes ne sont pas sur la même ligne : difficile de trouver ! - les en-têtes eux-mêmes ne sont pas identiques entre eux : encore plus difficile de trouver !! Un double-clic sur la feuille 'Performance Source' démarre la macro. Le fichier 'matrice' est censé se trouver dans le même répertoire que 'auto'. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) ' Dim sWBk As Workbook, sWkA As Worksheet, sWkB As Worksheet Dim iRowA%, iRowB%, iCol1%, iCol2% ' Cancel = True Application.ScreenUpdating = False ' Set sWBk = Workbooks.Open(ThisWorkbook.Path & "\matrice2021.xlsx") Set sWkB = sWBk.Worksheets("Feuil1") iRowA = Cells(Rows.Count, 4).End(xlUp).Row 'définir la dernière ligne utilisée iRowB = sWkB.Cells(Rows.Count, 1).End(xlUp).Row 'définir la dernière ligne utilisée ' For x = 2 To UsedRange.Columns.Count For y = 1 To sWkB.UsedRange.Columns.Count If Trim(Replace(Cells(2, x), Chr(160), Chr(32))) = Trim(Replace(sWkB.Cells(3, y), Chr(160), Chr(32))) Then _ Range(fctCol(x) & iRowA + 1).Resize(iRowB - 3).Value = sWkB.Range(fctCol(y) & "4:" & fctCol(y) & iRowB).Value: _ Exit For Next Next sWBk.Close False ' Application.ScreenUpdating = True MsgBox ("Terminé !") ' End Sub A+...

Curulis · Answer

Rapidos, à l'aveugle, sans fichier donc, impossible de vérifier... mais aussi pour simplifier le code ! La fonction fctCol() extrait la lettre de la colonne passée en argument. Oserais-je dire : à tester... Sub Fusion() ' Dim sWBk As Workbook, sWkA As Worksheet, sWkB As Worksheet Dim iRowA%, iRowB%, iCol1%, iCol2% ' Application.ScreenUpdating = False ' Set sWBk = Workbooks.Open("Nom.Fichier") Set sWkB = sWBk.Worksheets("Feuil1") Set sWkA = Worksheets("Performance Source") iRowA = sWkA.Cells(Rows.Count, 4).End(xlUp).Row 'définir la dernière ligne utilisée iRowB = sWkB.Cells(Rows.Count, 1).End(xlUp).Row 'définir la dernière ligne utilisée ' For x = 2 To sWkA.UsedRange.Columns.Count For y = 3 To sWkB.UsedRange.Columns.Count If sWkA.Cells(3, x) = sWkB.Cells(3, y) Then _ sWkA.Range(fctCol(x) & iRowA + 1).Resize(iRowB - 3).Value = sWkB.Range(fctCol(y) & "4:" & fctCol(y) & iRowB).Value: _ Exit For Next Next ' Application.ScreenUpdating = True MsgBox ("terminé") ' End Sub Public Function fctCol(ByVal iCol%) As String ' fctCol = Split(Columns(iCol).Address(ColumnAbsolute:=False), ":")(1) ' End Function A+...