Transposer des données selon des N° de folios

[Boby71C]

Bonjour à toutes et tous

Petite pane en VBA

Le but est de faire une liste d'étiquettes en 4 rangées pour alimenter l'imprimante

J'arrive à extraire les données les unes derrière les autres, mais l'idéal serait:

Mettre les repères de la colonne B en colonnes C-D-E-F par folio.
A chaque changement de folio, sauter 1 ligne
Exemple en fichier joint avec la première étiquette en colonne C de la série avec le N° de folio

Merci pour votre précieuse aide

 

[Boby71C]

Re : Transposer des données selon des N° de folios

Bonjour à toutes et tous

J'ai amélioré mon code, que voici:

Sub Reperes4Col()

Dim Folio As Variant
Folio = 1

Application.ScreenUpdating = False

'Effacer les données existantes en colonnes A-B-C-D-E-F
Columns("A:F").Select
Selection.ClearContents
Range("A1").Select

''Importer les données
' Workbooks.Open Filename:="D:\Repères P Peleija\Lien_Schema_Ndt.XLS"
' Range("A2:B10000").Select
' Selection.Copy
' Windows("Transposition par folios.xlsm").Activate
' ActiveSheet.Paste
' Range("A1").Select
' Windows("Lien_Schema_Ndt.XLS").Activate
' Range("A1").Select
' Application.CutCopyMode = False
' ActiveWindow.Close

Rep_Folio = ActiveCell.Offset(0, 0).Value

While Cells(Folio, 2).Value <> ""
ActiveCell(Folio, 3).FormulaR1C1 = _
"=OFFSET(R1C2,(ROW()-1)*4+INT((COLUMN()-3)),MOD(COLUMN()-3,1))"
ActiveCell(Folio, 4).FormulaR1C1 = _
"=OFFSET(R1C2,(ROW()-1)*4+INT((COLUMN()-3)),MOD(COLUMN()-3,1))"
ActiveCell(Folio, 5).FormulaR1C1 = _
"=OFFSET(R1C2,(ROW()-1)*4+INT((COLUMN()-3)),MOD(COLUMN()-3,1))"
ActiveCell(Folio, 6).FormulaR1C1 = _
"=OFFSET(R1C2,(ROW()-1)*4+INT((COLUMN()-3)),MOD(COLUMN()-3,1))"

Folio = Folio + 1
Wend

'Transformer les formules en données texte
Columns("C:F").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False

'Effacer les 0
ActiveCell.Offset(0, 2).Range("A1").Select
Cells.Find(What:="0", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False).Activate
ActiveCell.Range("A110000").Select
Selection.ClearContents
Range("A1").Select

''Supprimer les colonnes A et B dont nous n'avons plus besoin
' Columns("A:B").Select
' Selection.Delete Shift:=xlToLeft
' Range("A1").Select

Application.ScreenUpdating = True

End Sub


Mais incapable de trouver la solution pour qu'à chaque changement de folio de la colonne A, celui-ci se positionne sur la première étiquette.

Votre aide me serait très précieuse.

Merci