Scinder une colone en plusieurs puis extraire chaques colonnes fichiers

Bonjour à tous,

Tout d'abord, je tiens à vous remercier car jusqu'a présent, bien que novice en VBA, j'ai pu faire bon nombre de projets grâce à vos posts.

Voici ce que je souhaite faire :

J'ai un fichier avec une seule colone, d'environ 50 000 lignes.

Je souhaite scinder ce fichier en plusieurs petits fichiers de 2000 lignes max. Le nommage est pas important je m'occuperais de le modifier une fois que j'aurais la solution.

Ce que j'ai commencé à faire, c'est séparer les 50 000 lignes en colonnes dans la même feuille avec ce code :

Dim lastRow As Long, copynumRow As Long
Dim cRow As Long, cCol As Long

Application.ScreenUpdating = False

copynumRow = 2000
cCol = 2
cRow = 1 + copynumRow

With ActiveSheet
       lastRow = .Range("A" & .Rows.Count).End(xlUp).Row

       Do While cRow <= lastRow

           .Range("A" & cRow).Resize(copynumRow, 1).Cut _
               Destination:=.Cells(1, cCol).Resize(copynumRow, 1)

           cRow = cRow + copynumRow
           cCol = cCol + 1
       Loop
End With

Application.ScreenUpdating = True

j'obtiens donc 25 colonnes environ que je souhaiterais extraire en autant de fichiers que de colonnes et c'est là que je bloque.

L'idée serait :

colonne A reste sur l'onglet 1

Créer un nouvel onglet

couper la colonne B de l'onglet 1 et coller sur l'onglet 2 colonne A

Créer un nouvel onglet

couper la colonne C de l'onglet 1 et coller sur l'onglet 3 colonne A

Créer un nouvel onglet

couper la colonne D de l'onglet 1 et coller sur l'onglet 4 colonne A

etc ... jusqu’à ce que la colonne X de l'onglet 1 soit vide.

Une fois la séparation en onglet faite, je sais comment extraire ces onglets en fichiers, mon soucis se situe vraiment sur la partie <séparation des 25 colones en 25 onglets>.

Je sais faire une séparation sur la base d'un critère d'une colonne mais ici je ne vois pas comment transposer cela.

Pour exemple voici ce que j'utilise pour séparer en onglets sur le critère d'une colonne ( ici la colonne O )

       DerLig = Range("A" & Rows.Count).End(xlUp).Row

        Range("O2:O" & DerLig).Copy Range("P1")

        Columns("P:P").RemoveDuplicates Columns:=1, Header:=xlNo

        DerLig_Bis = Range("P" & Rows.Count).End(xlUp).Row

        For s = 1 To DerLig_Bis
            Sheets("Export").Copy After:=Sheets(s)
            ActiveSheet.Name = Sheets("Export").Range("P" & s)
            ActiveSheet.DrawingObjects.Delete
                For j = DerLig To 2 Step -1
                    If ActiveSheet.Range("O" & j) <> Sheets("Export").Range("P" & s) Then
                        ActiveSheet.Rows(j).Delete

                    End If
                Next j
            Range("P:P").Delete
        Next s

Auriez vous des idées de solutions à m'apporter ?

En vous remerciant par avance,

Sébastien

Bonjour sebinou81, le forum,

Un essai à partir de ton code....

Sub test()
 Dim lastRow As Long, copynumRow As Long
 Dim cRow As Long, cCol As Long

Application.ScreenUpdating = False

   copynumRow = 2000
         cCol = 1
         cRow = 1 + copynumRow

      With Sheets("test")
       lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Do While cRow <= lastRow
         Sheets.Add after:=Worksheets(Worksheets.Count)
          ActiveSheet.Name = Sheets(1).Name & Worksheets.Count
         .Range("A" & cRow).Resize(copynumRow, 1).Cut _
               Destination:=ActiveSheet.Cells(1, cCol).Resize(copynumRow, 1)
           cRow = cRow + copynumRow
        Loop
     End With

Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

CTRL + e pour lancer la macro

Cordialement,