Copie cellules excel, creation onglets

[arthurho]

Bonjour,

J'ai réalisé un script qui parcours un fichier excel et crée un onglet a chaque changement de nom dans une cellule du fichier initial (colonne "F"). Une fois l'onglet crée, je copie ligne par ligne les lignes contenant le nom qui a permis la création de l'onglet.

Malheureusement, toutes les lignes ne sont pas copiées, elles sont copiées de 2 en 2

Avez vous une solution ?

Merci de votre aide

Sub LireFichier3()


Dim Z1 As String, Z2 As String, LgSource As Range
Dim l As Long, tableau() As String
Dim sourceRange As Range
Dim destrange As Range
Dim k As Integer


With Sheets("Feuil1").Range("F2:F20")
.Select
  Do While Not (IsEmpty(ActiveCell))
    
    Z2 = ActiveCell.Value
    tableau = Split(Z2, "_")
    
    If Z1 <> tableau(1) Then
    
        k = 1
        ActiveCell.Interior.ColorIndex = 3
        Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
        ActiveSheet.Name = tableau(1)
        
    End If
    
    Sheets("Feuil1").Select

    Z1 = tableau(1)
   
    Set sourceRange = Sheets("Feuil1").Cells(ActiveCell.Row, 1).Range("A" & k & ":L" & k)
    Set destrange = Sheets(tableau(1)).Range("A" & k & ":L" & k)
    sourceRange.Copy destrange
    k = k + 1

    Selection.Offset(1, 0).Select
    Loop
  
End With
End Sub

 

[jpb388]

Re : Copie cellules excel, creation onglets

Bonjour
essaye celle ci

Sub LireFichier3()


Dim Z1 As String, Z2 As String, LgSource As Range
Dim l As Long, tableau() As String
Dim sourceRange As Range
Dim destrange As Range
Dim k As Integer


With Sheets("Feuil1").Range("F1:F" & Range("f" & Rows.Count).End(xlUp).Row)
.Select
Do While Not (IsEmpty(ActiveCell))

Z2 = ActiveCell.Value
tableau = Split(Z2, "_")

If Z1 <> tableau(1) Then

k = 1
ActiveCell.Interior.ColorIndex = 3
Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = tableau(1)

End If

Sheets("Feuil1").Select

Z1 = tableau(1)
Set sourceRange = Sheets("Feuil1").Range("A" & ActiveCell.Row & ":L" & ActiveCell.Row)
Set destrange = Sheets(tableau(1)).Range("A" & k & ":L" & k)
sourceRange.Copy destrange
k = k + 1

Selection.Offset(1, 0).Select
Loop

End With
End Sub