Selection et copy plusieurs lignes si

[Wildcat]

Bonjour,

Voilà, je crois que je ne suis pas loin, mais je n'arrive pas à finaliser cette macro.

J'ai plusieurs champs, dont un qui est un code pays. Evidement, plusieurs lignes ont le même code pays.

Ce que je souhaite, c'est qu'Excel parcours la liste, repère les lignes avec le même code pays (dans la colonne H), copie ces lignes, dans un autre classeur, sur une nouvelle feuille qui prendrai le nom du code pays, et ainsi de suite jusqu'à la fin de la feuille.

Voici ce que j'ai trouvé, moitié piquer dans l'aide microsoft moitié fait seule :

For Each rw In Worksheets(1).Cells(1, 8).CurrentRegion.Rows
    this = rw.Cells(1, 8).Value
    If this = last Then rw.Copy
    last = this
    Workbooks("Rail_per_Country.xls").Sheets.Add
    ActiveSheet.Paste
    Sheets(1).Name = Range("H1").Value
Next

La dernière partie (création de la nouvelle page dans le classeur) se passe bien, mais c'est au dessus : j'ai l'impression qu'il faut définir ce que doit être rw, et je n'arrive pas à savoir ce qu'il faut mettre... Et en plus on dirait que la macro tourne en rond en fait :

if this = last

, et après on a

last = this

...

D'avance, merci pour votre aide.

 

[Pierrot93]

Re : Selection et copy plusieurs lignes si

Bonsoir Wildcat

Si jai bien compris, pas sur, regarde le code si-dessous si il peut t'aider, désolé mais pas eut le temps de tester...

Option Explicit
Sub test()
Dim i As Integer, j As Integer, w As Worksheet, b As Boolean
'nom classeur et feuille source à adapter
With Workbooks("Classeu1.xls").Sheets("Feuil1")
    For i = 1 To .Range("A65536").End(xlUp).Row
        b = False
        For j = i + 1 To .Range("A65536").End(xlUp).Row
            If .Range("H" & i).Value = .Range("j" & i).Value Then
                If b = False Then
                    With Workbooks("Rail_per_Country.xls")
                        Set w = .Sheets.Add(, .Sheets.Count)
                    End With
                    w.Name = .Range("H" & i).Value
                    .Range(.Cells(i, 1), .Cells(i, .Range("IV" & i).End(xtoleft).Column)).Copy _
                        w.Range("A65536").End(xlUp).Offset(1, 0)
                End If
                .Range(.Cells(j, 1), .Cells(j, .Range("IV" & j).End(xtoleft).Column)).Copy _
                        w.Range("A65536").End(xlUp).Offset(1, 0)
                b = True
            End If
        Next j
    Next i
End With
End Sub

A voir si tu peut l'adapter à ton projet, sinon mets un petit fichier en pièce jointe, plus facile pour t'aider.

bonne soirée
@+