XL 2013 Ne pas copier les lignes complètes

[Usine à gaz]

Bonjour à toutes et à tous,

ça fait longtemps et comme je vais mieux (pour l'instant), je me remets à l'amélioration de mes connaissances et, bien entendu, j'ai besoin de votre aide si précieuse.

Voici ma problématique :
J'ai un code que je pense avoir trouvé ici (comme d'hab )

Sub Copie()
    Dim L As Long
    Dim LignesSel As Range
    For Each cel In Feuil1.Range("A2:A" & [A2].End(xlDown).Row)
        If cel.Value = "juju" Or cel.Value = "lola" Then
            If Not LignesSel Is Nothing Then
                Set LignesSel = Union(LignesSel, cel.EntireRow)
            Else
                Set LignesSel = cel.EntireRow
            End If
        End If
    Next
    If Not LignesSel Is Nothing Then LignesSel.Copy Feuil2.[A2]
    Feuil2.Select
    [A1].Select
End Sub

Il fonctionne parfaitement et j'en remercie encore l'auteur

Ce code copie les lignes entièrement et j'aurais besoin qu'il de me copie qu'une partie des lignes, par exemple toutes les lignes col A à D

Et ça, je ne sais pas faire et malgré mes recherches et essais, j'ai pas trouvé.

Auriez-vous la solution ? LOL ça m'arrangerait bien

Je joins le fichier test.
Un grand merci pour tout ce que vous faites.
Bonne journée à toutes et à tous,
Amicalement,
Arthour973,

 

[job75]

Bonjour Lionel, heureux de te retrouver,

Il suffit de limiter les lignes avec Resize :

           If Not LignesSel Is Nothing Then
                Set LignesSel = Union(LignesSel, cel.Resize(, 4))
            Else
                Set LignesSel = cel.Resize(, 4)
            End If

A+

 

[zebanx]

Bonjour @arthour973, job75, le forum
Un autre code
@+

  Sub Copie_F2()
  Dim L As Long
  Dim LignesSel As Range

    Set F1 = Sheets("Feuil1")
    Set F2 = Sheets("Feuil2")
    derlF2 = F2.Cells(Rows.Count, 1).End(3).Row

    For Each cel In Feuil1.Range("A2:A" & [A2].End(xlDown).Row)
        If cel.Value = "juju" Or cel.Value = "lola" Then
        Range(F1.Cells(cel.Row, 1), F1.Cells(cel.Row, 4)).Copy F2.Range("A" & derlF2 + 1)
        derlF2 = F2.Cells(Rows.Count, 1).End(3).Row
        End if
    Next

    F2.Select
    [A1].Select
End Sub

 

[Usine à gaz]

Bonjour Job,
Heureux aussi

Merci encore une fois pour m'avoir répondu (je ne les compte plus) LOL, je n'avais pas pensé à Resize

Je vais voir et je te dis.
Amicalement,
Lionel,

 

[Usine à gaz]

Bonjour Zebanx,

Un grand merci à toi aussi pour m'avoir répondu
Je vais tester et je reviens.
Amicalement,
Arthour973

 

[Usine à gaz]

Re Job,

Super ça marche nickel
Je te remercie,
Amicalement,
Lionel,

 

[Usine à gaz]

Re Zebanx,

Super ça marche
Un grand merci aussi,
Amicalement,
Arthour973

 

[job75]

Re, salut zebanx,

La copie des lignes une par une de zebanx prend beaucoup trop de temps s'il y a beaucoup de lignes à copier.

La méthode Union du post #1 est plus rapide sauf s'il y a beaucoup (plusieurs milliers) de zones disjointes à unir.

Il n'y a pas de problème avec le filtre automatique :

Sub Copie_filtre()
Dim F As Worksheet
Set F = Feuil2 'CodeName de la feuille de destination
F.Cells.Delete 'RAZ
With Feuil1.UsedRange.Resize(, 4)
    .AutoFilter 1, "juju", xlOr, "lola" 'filtre automatique
    .Copy Feuil2.[A1]
    .Parent.AutoFilterMode = False
End With
F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub

Et si l'on veut copier uniquement les valeurs la méthode par tableau VBA est la plus rapide :

Sub Copie_tableau()
Dim F As Worksheet, tablo, i&, n&, j%
Set F = Feuil2 'CodeName de la feuille de destination
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
tablo = Feuil1.UsedRange.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 1) = "juju" Or tablo(i, 1) = "lola" Then
        n = n + 1
        For j = 1 To 4: tablo(n, j) = tablo(i, j): Next
    End If
Next
If n Then F.[A2].Resize(n, 4) = tablo
F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub

A+

 

[Usine à gaz]

Vraiment merci à toi pour tant de précision.
et ... ça marche super bien
Amicalement,
Lionel,

 

[zebanx]

Re-

Bon eh bien puisqu'on y est, test sur 30.000 lignes avec un code de JOB75 himself (the "master" of XLD) et sur 30.000 lignes on tourne sur les codes de ce post + ceux du 8 à moins de 0.1 s sauf sur les codes initiaux, comme indiqué par JOB75.
(Tous les codes sont mis dans ce fichier si tu veux vérifier @job75).

Tu avais envoyé ce code très agréable (et très légèrement modifié pour ce cas) pour une course de chevaux de ce cher Guido... qui se fait rare lui aussi (surement qu'il a touché le quinté plus dans l'ordre)

@+

Sub sh01_code_sheet_2()
[COLOR=#b30000][COLOR=#b30000]'code de JOB75[/COLOR][/COLOR]
Dim t0

t0 = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurité
Sheets(2).Range("A1:E" & Rows.Count).Delete xlUp 'RAZ
[g2] = "=OR(A2=""juju"", A2=""lola"")"
Range("A1:D" & Rows.Count).AdvancedFilter xlFilterCopy, Sheets(1).[G1:G2], Sheets(2).[A1:D1] '[A1:D1] 'filtre avancé
Sheets(1).[g2] = ""
Application.EnableEvents = True
MsgBox Format(Timer - t0, "0.000\sec.")
End Sub

 

[Usine à gaz]

à Job75,
à Zébanx,
Re-bonjour,
Super vraiment

 

[Usine à gaz]

Bonjour à toutes et à tous,

Encore merci à Job75 et à Zébanx pour leur aide si précieuse.
Les codes fonctionnent super bien.
Je vais retenir le code de Job75 qui est super rapide :

Sub Copie_tableau_job75_origine()
Dim F As Worksheet, tablo, i&, n&, j%, t0
t0 = Timer
Set F = Feuil2 'CodeName de la feuille de destination
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
tablo = Feuil1.UsedRange.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 2) > 148 Then 'tablo(i, 2)vérifie sur col B
        n = n + 1
        For j = 1 To 4: tablo(n, j) = tablo(i, j): Next
    End If
Next
If n Then F.[A2].Resize(n, 4) = tablo
'F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
MsgBox Format(Timer - t0, "0.000_sec")
End Sub

Mais voilà, c'est en avançant qu'on s'aperçois que c'est plus compliqué LOL

Il m'est apparu que j'aurai besoin de copier les cellules de la Feuill1 comme présenté dans la Feuille "ma demande".
C'est à dire à partir de la colonne B

J'ai beau triffouiller le code mais je n'y arrive pas.
Auriez-vous la solution ?
Je joins le fichier test.

Encore une fois un grand merci pour votre gentillesse.
Amicalement,
Lionel,

 

[zebanx]

Bonjour @arthour973, le forum

En devançant peut-être un peu JOB75 sur son code et en espérant avoir compris.

@+
zebanx

Sub Copie_tableau_job75_2()
Dim F As Worksheet, tablo, i&, n&, j%, t0

t0 = Timer
Set F = Feuil4
tablo = Feuil1.Range("B2:D" & Feuil1.Cells(Rows.Count, 2).End(3).Row)

'--- remplir tablo si valeur en colonne B > 148
For i = 2 To UBound(tablo, 1)
    If tablo(i, 1) > 148 Then
    n = n + 1
    For j = 1 To 3: tablo(n, j) = tablo(i, j): Next
    End If
Next
'--- restitution
If n Then F.[a2].Resize(n, 3) = tablo

F.Visible = xlSheetVisible
Application.Goto F.[A1], True
MsgBox Format(Timer - t0, "0.000_sec")
End Sub

 

[Usine à gaz]

Merci Zébanx,

Je vais regarder et je te dis

 

[zebanx]

Et peut-être pour plus de clarté en partant de la colonne "A" pour la définition de tablo.

Sub Copie_tableau_job75_colB_avecA()
Dim F As Worksheet, tablo, i&, n&, j%, t0

t0 = Timer
Set F = Feuil4
tablo = Feuil1.Range("A2:D" & Feuil1.Cells(Rows.Count, 2).End(3).Row)
ReDim tb(1 To UBound(tablo, 1), 1 To 3)

'--- remplir tablo si valeur en colonne B > 148
For i = 2 To UBound(tablo, 1)
    If tablo(i, 2) > 148 Then
    n = n + 1
    For j = 2 To 4
    tb(n, j - 1) = tablo(i, j)
    Next
End If
Next
'--- restitution
If n Then F.[a2].Resize(n, 3) = tb

F.Visible = xlSheetVisible
Application.Goto F.[A1], True
MsgBox Format(Timer - t0, "0.000_sec")
End Sub