découpage lignes avec code VBA

1 pièce(s) jointe(s)

Bonjour,

J'ai trouvé ce code VBA, aucun problème le code marche nickel.

Le seul souci c'est qu'il prend que la colonne A, je voudrais qu'il prenne les colonnes A à F

Merci pour votre aide ;)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub découper()
Dim derlig&, dercol&, prefixe, nom$, n&, nbfic&
Dim F1, F2, i&, i1&, i2&, newclas, first
 
   Application.ScreenUpdating = False
   Set F1 = ThisWorkbook.Sheets("Feuil1")
   Set F2 = ThisWorkbook.Sheets("Feuil2")
   With F2
      derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
      dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      nbfic = (derlig - 1) \ F1.Range("b3") - ((((derlig - 1) Mod F1.Range("b3"))) > 0)
   End With
   With F1
      prefixe = ThisWorkbook.Path
      If Right(prefixe, 1) <> "\" Then prefixe = prefixe & "\"
      prefixe = prefixe & .Range("b1")
      On Error Resume Next: MkDir prefixe: On Error GoTo 0
      If Right(prefixe, 1) <> "\" Then prefixe = prefixe & "\"
      prefixe = prefixe & .Range("b2")
      prefixe = prefixe & "-"
   End With
 
   With F2
      i1 = 2: i2 = i1 + F1.Range("b3") - 1
      Set newclas = Workbooks.Add
      Do
         .Range("a1").Resize(, dercol).Copy newclas.Sheets(1).Range("a1")
         .Range(.Cells(i1, "a"), .Cells(i2, dercol)).Copy newclas.Sheets(1).Range("a2")
         newclas.Sheets(1).Range("a1").Resize(, dercol).EntireColumn.AutoFit
         Application.DisplayAlerts = False
         n = n + 1
         Application.StatusBar = "fichier n° " & n & " / " & nbfic
         nom = prefixe & Left("0000", 4 - Len("" & n)) & n & ".xlsx"
         newclas.SaveAs Filename:=nom, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
         Application.DisplayAlerts = True
         If IsEmpty(first) Then first = nom
         i1 = i1 + F1.Range("b3"): i2 = i2 + F1.Range("b3")
         If i1 > derlig Then Exit Do
         newclas.Sheets(1).UsedRange.Clear
      Loop
   End With
   newclas.Close SaveChanges:=False
   Application.StatusBar = False
   MsgBox "Création de " & n & " fichiers terminée !" & vbLf & vbLf & _
      "depuis  " & vbLf & first & vbLf & vbLf & _
      "jusqu'à " & vbLf & nom, vbInformation
End Sub

Bonjour,

Dans cette ligne de code :
Code:

1 2 dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column
il te faut mettre 4 et non 1 car c'est sur la quatrième ligne que se trouvent les entêtes de colonnes !
Donc :
Code:

1 2 dercol = .Cells(4, .Columns.Count).End(xlToLeft).Column

Bonjour

En mode pas à pas la variable

Code:

dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column

est égale à 1

en la remplaçant par
Code:

1 2 dercol = .Cells(4, .Columns.Count).End(xlToLeft).Column
la valeur de dercol change

Bonne journée

Theze a été plus rapide que moi.....

Je pense que le mode pas à pas t'aurait permis de trouver.

Merci a vous Deux pour votre rapidité :D

Bonne journée