Copie des data sur deux colonnes

Question

Je galère depuis 2 jours sur le sujet et je comprend plus pourquoi. Je penses avoir récupérer les données de mes onglets mais je n'arrive pas à les coller sur ma feuille sur 2 colonnes à n ligne, puis à n, décaler le collage sur les deux colonne suivantes. Je joins un petit fichier avec des exemples : j'espères qu'il n'y a pas trop d'erreur dans la premiere partie de mon code Si vous avez des suggestions pour réaliser ma mise en page, je suis prenneur...

galopin01 · Answer

Tes explications sont pas claires et ton fichier encore moins. Quand à ton code il n'y en a pas puisque ton fichier est un .xlsx. C'est le WE sort la tête du guidon ! Va faire un tour en forêt : Tu y verras peut-être un peu plus clair avec un bon bol d'oxygène... A+...

galopin01 · Answer

Pfff... rien compris !

Bon je suppose qu'avec ça tu sauras te débrouiller...

Option Explicit
DefBool Y
Sub Etiquette_classeur()
Dim i%, iRow%, iCol%, iR%, iC%, x%, tete$, S1$, S2$
Dim Y, yVraiAuMoinsUneFois
Dim a, b, d
Application.DisplayAlerts = False
tete = InputBox("Saisir le préfix du matériel" & Chr(13) & Chr(13) & _
         "(CEN,ENC,PIP,MIC,REV,SON)", "Edition des étiquettes classeur")
affiche_tous
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Worksheets.Count
   With Worksheets(i)
      Y = Left(.Name, 3) = tete
      If Y Then
         yVraiAuMoinsUneFois = 1
         .Activate
         S1 = .Range("FdV_Denom2").Value
         S2 = .Range("FdV_Serie").Value
         d.Item(S1) = S2
      End If
   End With
Next
If Not yVraiAuMoinsUneFois Then GoTo FIN

' suppression de la feuille à imprimer s'il elle n'a pas déjà été supprimée
On Error Resume Next
Sheets("_Etiquettes_Cla_asup").Delete
'ne pas remettre la gestion d'erreur
Sheets("_Etiquettes_classeurs").Visible = True
Sheets("_Etiquettes_classeurs").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "_Etiquettes_Cla_asup"
'--------------------------------------------- OPTION 1 : Ecriture dans les colonnes A et B
'            [A1].Resize(d.Count) = Application.Transpose(d.keys)
'            [B1].Resize(d.Count) = Application.Transpose(d.items)
'--------------------------------------------- OPTION 2 : Ecriture dans iRow et iCol
'transfert dans des Array
   a = d.keys   ' transfert dans tableau a(0 To n-1)
   b = d.items  ' transfert dans tableau b(0 To n-1)
iRow = 3
iCol = Application.RoundUp(d.Count / iRow, 0)
For iR = 1 To iRow
   For iC = 1 To iCol * 2 Step 2
      Cells(iR, iC) = a(x)
      Cells(iR, iC + 1) = b(x)
      x = x + 1
   Next
Next
'-------------------------------------------------- Fin OPTION 2
On Error GoTo 0
Sheets("_Etiquettes_Cla_asup").Select
Exit Sub
FIN:
End Sub

A+

[Edit] Tu pars ou après ?