Microsoft 365 Copier/coller en boucle avec un nb variable de ligne

[A-F]

Bonjour, j'ai besoin de votre aide
Je travail sur un projet ou je dois exporter les diffèrents colonnes qui ne sont pas forcement les une à la suite des autre dans une autre fichier en fonctions d'une variable (type de acte qui prend 4 valeur ; A01, A02,A03,A04) donc je dois avoir 4 fichiers à la fin de mon exporte.
Sauf que pour A01 et A02 on peut avoir plusieurs qui sont dans diffèrent colonnes. donc il faut les copier autant de fois qu'il y a une acte.
Ma question c'est donc comment je peut copier/coller une ligne en boucle, en fonction de nb de A01?

J'ai débuté par faire un code pour compter le nb d'acte par ligne et j'envisager de faire en boucle en fonction de nb de acte par ligne. J'arrive à avoir le nb de acte par ligne mais le copier/coller ne fonction pas comme je pensais.
Merci d'avance pour votre temps.


Voici mon code:
Sub CopierLeTDB_Bis()
Dim C As Range
Dim nb As Integer, i As Integer, nbA01 As Integer, TotalA01 As Integer, j As Integer, NextRow As Range
Dim ThisValue As String
Dim classeur As Workbook
Dim LaFeuille As Worksheet
Dim Msg As String

nb = getNbDossier()


'Activer le fichier TDB_PSG.xlsm
Workbooks("TDB_PSG_B.xlsm").Activate

'Supprimer le ficher qui vient d'être carrée à chaque lancement de la boucle --> il faut supprimer cette étape une fois le prog est terminé ***
Kill "Z:\N.....\fichier_import_A1.xlsx"

' Save le fichier exporte
Workbooks.Add.SaveAs Filename:="Z:\......\fichier_import_A1"

'Activer le fichier export
Workbooks("fichier_import_A1.xlsx").Activate


'Copier les donner de chaque ligne/dossier

For i = 6 To 8 'nb + 4 'parcourir chaque ligne en comencant par ligne 6
Workbooks("TDB_PSG_B.xlsm").Worksheets("TDB - Type").Range("E" & i & ":E" & i).Copy 'UserEmail

'initialiser le nb d'acte à 0
nbA01 = 0
For Each C In Workbooks("TDB_PSG_B.xlsm").Worksheets("TDB - Type").Range("AS" & i & "V" & i) 'la palage de Acte A01

If C.Value = "A01" Then ' si la valeure de cellule = A01

nbA01 = nbA01 + 1
'Msg = Msg & "Il y a " & nbA01 & " acts. " '& Chr(10)
'MsgBox nbA01

End If

Next

'MsgBox nbA01
'MsgBox Msg
TotalA01 = nbA01 'j'ai le bon nom de act par ligne
'MsgBox TotalA01

' je n'arrive pas à copier en boucle
Workbooks("TDB_PSG_B.xlsm").Worksheets("TDB - Type").Range("E" & i & ":E" & i).Copy

For j = 1 To TotalA01 ' il compte ca comme num de la ligne

Workbooks("fichier_import_A1.xlsx").ActiveSheet.Range("A1").PasteSpecial
Next

Next


End Sub

 

[Phil69970]

Bonjour @A-F

Et avec le fichier cela donne quoi ?

@Phil69970

 

[sylvanu]

Bonjour A-F, Phil,
Et mettez au moins votre code entre balises ( </>, à droite de l'icone GIF )
Ce sera plus digeste et plus lisible.

 

[A-F]

Bonjour @A-F

Et avec le fichier cela donne quoi ?

@Phil69970

Bonjour @A-F

Et avec le fichier cela donne quoi ?

@Phil69970

Bonjour,
Tu trouves ci joint mon fichier de base ( anonymisé) et un exemple de fichier pour importer les données pour acte 1 (A01).

 

[A-F]

Bonjour A-F, Phil,
Et mettez au moins votre code entre balises ( </>, à droite de l'icone GIF )
Ce sera plus digeste et plus lisible.

Bonjour, oui j'avais pas fait attention, voici le code entre balise :

Sub CopierLeTDB_Bis()
    Dim C As Range
    Dim nb As Integer, i As Integer, nbA01 As Integer, TotalA01 As Integer, j As Integer, NextRow As Range
    Dim ThisValue As String
    Dim classeur As Workbook
    Dim LaFeuille As Worksheet
    Dim Msg As String

    nb = getNbDossier()
    
    
    'Activer le fichier TDB_PSG.xlsm
    Workbooks("TDB_PSG_B.xlsm").Activate
    
    'Supprimer le ficher qui vient d'être carrée à chaque lancement de la boucle --> il faut supprimer cette étape une fois le prog est terminé ***
    Kill "Z:\NECESSAIRES CONSEILLERS ENERGIES\SARE\Traitement\Export\fichier_import_A1.xlsx"
    
    ' Save le fichier exporte
    Workbooks.Add.SaveAs Filename:="Z:\NECESSAIRES CONSEILLERS ENERGIES\SARE\Traitement\Export\fichier_import_A1"
    
    'Activer le fichier export
    Workbooks("fichier_import_A1.xlsx").Activate
    
    
    'Copier les donner de chaque ligne/dossier
    
   For i = 6 To 8 'nb + 4 'parcourir chaque ligne en comencant par ligne 6
    
    'initialiser le nb d'acte à 0
    nbA01 = 0
        For Each C In Workbooks("TDB_PSG_B.xlsm").Worksheets("TDB - Type").Range("AS" & i & ":DV" & i) 'la palage de Acte A01
            
                If C.Value = "A01" Then ' si la valeure de cellule = A01
            
                        'nbA01 = nbA01 + 1
                        'Msg = Msg & "Il y a " & nbA01 & " acts. " '& Chr(10)
                        'MsgBox nbA01
                        ''selectionner la plage à copier : je sais pas comment fonciton offset j'ai peut etre mal choisit ma plage ( le cellue avant A01 jusquà 9 celluls apres )
                       Workbooks("TDB_PSG_B.xlsm").Worksheets("TDB - Type").Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(9, 0)).Copy
                    
                End If
            
        Next
  
        'MsgBox nbA01
        'MsgBox Msg
        'TotalA01 = nbA01 'j'ai le bon nombre de act par ligne
        'MsgBox TotalA01
              
              ' je n'arrive pas à copier en boucle
                Workbooks("fichier_import_A1.xlsx").ActiveSheet.Range("A1").PasteSpecial
          
    Next

    
End Sub

'****laCellule = Cells(noLigne, noColonne)