Macro copy d'une base à une autre

Question

Merci d'avance l'objectif de transformer la liste des factures de chaque ligne de la feuille REGLEMNT dans la feuille BASE_DETAIL_REGLEMENTS une facture plar ligne en ajoutant les informations suivantes pour chaque ligne de facture RefReglement CODE FOURNISSEUR DATE DE REGLEMENT REFERENCE CHEQUE ECHEANCE TRAITE / DATE DU VIREMENT Sub copy() Dim i As Long Application.ScreenUpdating = False Dim sht1 As Worksheet Dim sht2 As Worksheet Set sht1 = BaseDetailReglement Set sht2 = Reglement i = 6 x = 3 For i = 6 To 190 For j = 19 To 84 If sht2.Cells(i, j).Value &lt;&gt; "" Then sht1.Cells(x, 1).Value = sht2.Cells(i, 2).Value sht1.Cells(x, 2).Value = sht2.Cells(i, 1).Value sht1.Cells(x, 3).Value = sht2.Cells(i, 6).Value sht1.Cells(x, 4).Value = sht2.Cells(i, 4).Value sht1.Cells(x, 5).Value = sht2.Cells(i, 5).Value sht1.Cells(x, 6).Value = sht2.Cells(i, j).Value sht1.Cells(x, 7).Value = sht2.Cells(i, j + 1).Value sht1.Cells(x, 8).Value = sht2.Cells(i, j + 2).Value x = x + 1 End If Next Next 'Next 'End With Application.ScreenUpdating = True End Sub&lt;br&gt...

Arturo83 · Accepted Answer

Ok, j'avais pas vu que les 13 dernières colonnes étaient masquées, ce qui évidemment me faisait récupérer les valeurs de ces colonnes. voici la macro corrigée.

Sub Copie()
    Dim sht1 As Worksheet, sht2 As Worksheet
    Dim Tabl_1 As ListObject, Tabl_2 As ListObject
    Dim i As Long, x As Long

    Application.ScreenUpdating = False
    Set sht1 = Sheets("BASE_DETAIL_REGLEMENTS")
    Set sht2 = Sheets("REGLEMENT")
    Set Tabl_1 = sht1.ListObjects("BaseDetailReglment")
    Set Tabl_2 = sht2.ListObjects("reglement")
    DerLig_f2 = Tabl_2.DataBodyRange.Rows.Count
    DerCol_f2 = Tabl_2.DataBodyRange.Columns.Count
    sht1.Range("A3:H10000").ClearContents
    x = 3
    For i = 6 To DerLig_f2
        For j = 20 To DerCol_f2 - 14 Step 3
            If sht2.Cells(i, j) <> "" Then
                sht1.Cells(x, "A") = sht2.Cells(i, "B") 'RefReglement
                sht1.Cells(x, "B") = sht2.Cells(i, "A") 'CODE FOURNISSEUR
                sht1.Cells(x, "C") = sht2.Cells(i, "F") 'DATE DE REGLEMENT
                sht1.Cells(x, "D") = sht2.Cells(i, "D") 'REFERENCE CHEQUE
                sht1.Cells(x, "E") = sht2.Cells(i, "E") 'ECHEANCE  TRAITE / DATE DU VIREMENT
                sht1.Cells(x, "F") = sht2.Cells(i, j - 1) 'DATE FACTURE
                sht1.Cells(x, "G") = sht2.Cells(i, j) 'N° FACTURE
                sht1.Cells(x, "H") = sht2.Cells(i, j + 1) 'MONTANT FACTURE
                x = x + 1
            End If
        Next j
    Next i

    Set Tabl_1 = Nothing
    Set Tabl_2 = Nothing
    Set sht1 = Nothing
    Set sht2 = Nothing
    Application.ScreenUpdating = True
End Sub

Cdlt

Arturo83 · Answer

Attention, il y a des formules en colonne P de la feuille "règlement" qui génèrent des références circulaires, supprimez-les ou modifiiez-les. Votre code corrigé: Sub Copie() Dim sht1 As Worksheet, sht2 As Worksheet Dim Tabl_1 As ListObject, Tabl_2 As ListObject Dim i As Long, x As Long Application.ScreenUpdating = False Set sht1 = Sheets("BASE_DETAIL_REGLEMENTS") Set sht2 = Sheets("REGLEMENT") Set Tabl_1 = sht1.ListObjects("BaseDetailReglment") Set Tabl_2 = sht2.ListObjects("reglement") DerLig_f2 = Tabl_2.DataBodyRange.Rows.Count DerCol_f2 = Tabl_2.DataBodyRange.Columns.Count sht1.Range("A3:H10000").ClearContents x = 3 For j = 20 To DerCol_f2 Step 3 For i = 6 To DerLig_f2 If sht2.Cells(i, j) &lt;&gt; "" Then sht1.Cells(x, "A") = sht2.Cells(i, "B") 'RefReglement sht1.Cells(x, "B") = sht2.Cells(i, "A") 'CODE FOURNISSEUR sht1.Cells(x, "C") = sht2.Cells(i, "F") 'DATE DE REGLEMENT sht1.Cells(x, "D") = sht2.Cells(i, "D") 'REFERENCE CHEQUE sht1.Cells(x, "E") = sht2.Cells(i, "E") 'ECHEANCE TRAITE / DATE DU VIREMENT sht1.Cells(x, "F") = sht2.Cells(i, j - 1) 'DATE FACTURE sht1.Cells(x, "G") = sht2.Cells(i, j) 'N° FACTURE sht1.Cells(x, "H") = sht2.Cells(i, j + 1) 'MONTANT FACTURE x = x + 1 End If Next i Next j Set Tabl_1 = Nothing Set Tabl_2 = Nothing Set sht1 = Nothing Set sht2 = Nothing Application.ScreenUpdating = True End Sub Cdlt...

Arturo83 · Answer

Je vous ai complètement oublié, voici la macro pour une exécution plus rapide? Sub Copie() Dim sht1 As Worksheet, sht2 As Worksheet Dim Tabl_1 As ListObject, Tabl_2 As ListObject Dim i As Long, j As Long Dim DerLig_f2 As Long, DerCol_f2 As Long Dim Rgl() As Variant Dim x As Long Application.ScreenUpdating = False Set sht1 = Sheets("BASE_DETAIL_REGLEMENTS") Set sht2 = Sheets("REGLEMENT") Set Tabl_2 = sht2.ListObjects("reglement") DerLig_f2 = Tabl_2.DataBodyRange.Rows.Count DerCol_f2 = Tabl_2.DataBodyRange.Columns.Count x = 1 ReDim Rgl(1 To DerLig_f2 + 5, 1 To DerCol_f2) For i = 6 To DerLig_f2 + 5 For j = 20 To DerCol_f2 - 14 Step 3 If sht2.Cells(i, j) &lt;&gt; "" Then If x &gt; UBound(Rgl, 1) Then 'Augmente la taille du tableau Rgl ReDim Preserve Rgl(1 To UBound(Rgl, 1) + 10, 1 To DerCol_f2) End If ' Stocke les données dans le tableau Rgl Rgl(x, 1) = sht2.Cells(i, "B").Value ' Regl Rgl(x, 2) = sht2.Cells(i, "A").Value ' Code Rgl(x, 3) = sht2.Cells(i, "F").Value ' Date_Regl Rgl(x, 4) = sht2.Cells(i, "D").Value ' Ref_Ch Rgl(x, 5) = sht2.Cells(i, "E").Value ' Date_Ech Rgl(x, 6) = sht2.Cells(i, j - 2).Value ' Date_Fact Rgl(x, 7) = sht2.Cells(i, j - 1).Value ' N°_Fact Rgl(x, 8) = sht2.Cells(i, j).Value ' Mont_Fact x = x + 1 If x &gt; DerLig_f2 + 5 Then GoTo Restitution End If Next j Next i Restitution: ' Copie le tableau Rgl dans les colonnes A à H de la feuille Sht1 à partir de la cellule A3 For i = 1 To x - 1 For j = 1 To 9 sht1.Cells(i + 2, j) = Rgl(i, j) Next j Next i Application.ScreenUpdating = True End Sub Cdlt...

6	616661	16/01/2023	3490945	1412	455,8	01/12/2022
6	616661	16/01/2023	3490945	1413	455,8	44 915,000
6	616661	16/01/2023	3490945	1528	337,362
6	616661	16/01/2023	3490945	12/01/1900	1236,472	1276919B
6	616661	16/01/2023	3490945	B	M	000

RefReglement	CODE FOURNISSEUR	DATE DE REGLEMENT	REFERENCE CHEQUE	ECHEANCE TRAITE / DATE DU VIREMENT	DATE FACTURE	N° FACTURE	MONTANT FACTURE
6	616661	16/01/2023	3490945		01/12/2022	1412	455,8
6	616661	16/01/2023	3490945		01/12/2022	1413	455,8
6	616661	16/01/2023	3490945		20/12/2022	1528	337,362