XL 2019 Copier d'une feuille à l'autre en ignorant la valeur zéro

Dadi147 · 13 Février 2023

Bonjour. Je souhaite copier des données de Sheet1 à Sheet2 à condition qu'il y ait une valeur nulle de la colonne F à N La ligne est supprimée et le reste copié. Le code suivant vérifie simplement la colonne F Je veux ignorer la ligne uniquement s'il y a une valeur nulle dans toutes les cellules

VB:

Sub CopyData()
 Dim x, y(), i As Long, ii As Long, iii As Long
Dim lr As Long
Set st = Sheets("sheet1")
Set WS = Sheets("résultat")

 lr = st.Range("D" & Rows.Count).End(xlUp).Row
 lr2 = WS.Range("A" & Rows.Count).End(xlUp).Row
 x = st.Range("D1:N" & lr)
 For i = 1 To UBound(x, 1)
 If x(i, 3) <> 0 Then
 iii = iii + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To iii)
 For ii = 1 To UBound(x, 2)
 y(ii, iii) = x(i, ii)
 Next
 End If
 Next
 With Sheets("résultat")
 WS.Range("a2:k" & lr2).ClearContents
 .[a1].Resize(iii, UBound(y, 1)) = Application.Transpose(y)
 End With
End Sub

job75 · 14 Février 2023

Pas bien clair le "souvent" mais bon considérons que les cellules vides sont des valeurs nulles :

VB:

Sub CopyData()
Dim F1 As Worksheet, derlig&, F2 As Worksheet
Set F1 = Sheets("Sheet1")
If F1.FilterMode Then F1.ShowAllData 'si la feuille est filtrée
derlig = F1.Range("D" & F1.Rows.Count).End(xlUp).Row
Set F2 = Sheets("Résultat")
Application.ScreenUpdating = False
F2.Cells.Delete 'RAZ
F1.Rows("1:" & derlig).Copy
F2.[A1].PasteSpecial xlPasteValues
F2.[A1].PasteSpecial xlPasteFormats
Application.CutCopyMode = 0
With F2.Rows("1:" & derlig)
    .Columns(1).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(1) = "=1/(SUMPRODUCT(N(RC[6]:RC[14]<>0))=9)"
    .Columns(1) = .Columns(1).Value 'supprime les formules
    .Sort .Cells(1)...

mapomme · 14 Février 2023

Bonjour @Dadi147 🙂,

Une version à la sauce de ma pomme. On utilise un seul tableau x à la fois pour le tableau source et pour le tableau résultat. Ceci évite les augmentations de taille répétées si on utilise un second tableau ainsi que le Transpose final.
Cliquez sur le bouton HOP!.

VB:

Option Explicit

Sub CopyData()
Dim x, i As Long, j As Long, der As Long, n As Long
Dim st As Worksheet, WS As Worksheet, s As String

   Application.ScreenUpdating = False
   Set st = Sheets("sheet1")
   der = st.Range("d" & Rows.Count).End(xlUp).Row
   x = st.Range("d1:n" & der)
   ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1)  'on ajoute une colonne vide à x
   ' dans cette colonne, on va y concaténer toutes les valeurs des colonnes précédentes (F à N)
   ' si F à N sont toutes vides, alors la dernière colonne de x sera égale à ""
   For i = 1 To UBound(x)
      For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j
   Next i
 
   Set WS = Sheets("résultat")
   WS.Range("a:k").ClearContents
 
   For i = 1 To UBound(x)
      If x(i, UBound(x, 2)) <> "" Then
         ' on déplace les lignes à copier vers le haut du tableau x
         ' on utilise le même tableau x pour la source et le résultat
         ' la ligne i prend la place de la ligne n (pas de chevauchement possible
         ' puisque n est toujours inférieur ou égal à la ligne courante i)
         n = n + 1
         For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next
      End If
   Next
 
   '  les données à copier sont les n premières lignes de x
   ' (sauf la dernière colonne de chaque ligne qui nous a servi à savoir
   ' si la ligne était vide ou non)
   With WS.Range("a1").Resize(n, UBound(x, 2) - 1)
      .Value = x
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
   End With
End Sub

Dadi147 · 14 Février 2023

Merci. Expérimentation en cours

mapomme à dit:

Bonjour @Dadi147 🙂,

Une version à la sauce de ma pomme. On utilise un seul tableau x pour à la fois pour le tableau source et pour le tableau résultat. Ceci évite les augmentations de taille répétées si on utilise un second tableau ainsi que le Transpose final.
Cliquez sur le bouton HOP!.

VB:

Option Explicit

Sub CopyData()
Dim x, i As Long, j As Long, der As Long, n As Long
Dim st As Worksheet, WS As Worksheet, s As String

   Application.ScreenUpdating = False
   Set st = Sheets("sheet1")
   der = st.Range("d" & Rows.Count).End(xlUp).Row
   x = st.Range("d1:n" & der)
   ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1)  'on ajoute une colonne vide à x
   ' dans cette colonne, on va y concaténer toutes les valeurs des colonnes précédentes (F à N)
   ' si F à N sont toutes vides, alors la dernière colonne de x sera égale à ""
   For i = 1 To UBound(x)
      For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j
   Next i
 
   Set WS = Sheets("résultat")
   WS.Range("a:k").ClearContents
 
   For i = 1 To UBound(x)
      If x(i, UBound(x, 2)) <> "" Then
         ' on déplace les lignes à copier vers le haut du tableau x
         ' on utilise le même tableau x pour la source et le résultat
         ' la ligne i prend la place de la ligne n (pas de chevauchement possible
         ' puisque n est toujours inférieur ou égal à la ligne courante i)
         n = n + 1
         For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next
      End If
   Next
 
   '  les données à copier sont les n premières lignes de x
   ' (sauf la dernière colonne de chaque ligne qui nous a servi à savoir
   ' si la ligne était vide ou non)
   With WS.Range("a1").Resize(n, UBound(x, 2) - 1)
      .Value = x
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
   End With
End Sub

Merci. Expérimentation en cours

Dadi147 · 14 Février 2023

mapomme à dit:

Bonjour @Dadi147 🙂,

Une version à la sauce de ma pomme. On utilise un seul tableau x à la fois pour le tableau source et pour le tableau résultat. Ceci évite les augmentations de taille répétées si on utilise un second tableau ainsi que le Transpose final.
Cliquez sur le bouton HOP!.

VB:

Option Explicit

Sub CopyData()
Dim x, i As Long, j As Long, der As Long, n As Long
Dim st As Worksheet, WS As Worksheet, s As String

   Application.ScreenUpdating = False
   Set st = Sheets("sheet1")
   der = st.Range("d" & Rows.Count).End(xlUp).Row
   x = st.Range("d1:n" & der)
   ReDim Preserve x(1 To UBound(x), 1 To UBound(x, 2) + 1)  'on ajoute une colonne vide à x
   ' dans cette colonne, on va y concaténer toutes les valeurs des colonnes précédentes (F à N)
   ' si F à N sont toutes vides, alors la dernière colonne de x sera égale à ""
   For i = 1 To UBound(x)
      For j = 3 To UBound(x, 2) - 1: x(i, UBound(x, 2)) = x(i, UBound(x, 2)) & x(i, j): Next j
   Next i
 
   Set WS = Sheets("résultat")
   WS.Range("a:k").ClearContents
 
   For i = 1 To UBound(x)
      If x(i, UBound(x, 2)) <> "" Then
         ' on déplace les lignes à copier vers le haut du tableau x
         ' on utilise le même tableau x pour la source et le résultat
         ' la ligne i prend la place de la ligne n (pas de chevauchement possible
         ' puisque n est toujours inférieur ou égal à la ligne courante i)
         n = n + 1
         For j = 1 To UBound(x, 2): x(n, j) = x(i, j): Next
      End If
   Next
 
   '  les données à copier sont les n premières lignes de x
   ' (sauf la dernière colonne de chaque ligne qui nous a servi à savoir
   ' si la ligne était vide ou non)
   With WS.Range("a1").Resize(n, UBound(x, 2) - 1)
      .Value = x
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
   End With
End Sub

Bonjour. Après l'expérience, j'ai remarqué que la valeur zéro requise est copiée lorsqu'il y a un zéro dans toutes les cellules de ligne de la colonne f à la colonne N, il est ignoré et les autres lignes sont copiées

job75 · 14 Février 2023

Bonjour Dadi147, mapomme, le forum,

Est-ce que les cellules vides sont considérées comme des valeurs nulles ?

A+

Dadi147 · 14 Février 2023

job75 à dit:
Bonjour Dadi147, mapomme, le forum,

Est-ce que les cellules vides sont considérées comme des valeurs nulles ?

A+

Souvent, il n'y aura pas de cellules complètement vides. Mais il y aura des valeurs 0. Je veux lors de la vérification de 0 dans toutes les cellules de ligne. Il est ignoré et le reste est copié

job75 · 14 Février 2023

Pas bien clair le "souvent" mais bon considérons que les cellules vides sont des valeurs nulles :

VB:

Sub CopyData()
Dim F1 As Worksheet, derlig&, F2 As Worksheet
Set F1 = Sheets("Sheet1")
If F1.FilterMode Then F1.ShowAllData 'si la feuille est filtrée
derlig = F1.Range("D" & F1.Rows.Count).End(xlUp).Row
Set F2 = Sheets("Résultat")
Application.ScreenUpdating = False
F2.Cells.Delete 'RAZ
F1.Rows("1:" & derlig).Copy
F2.[A1].PasteSpecial xlPasteValues
F2.[A1].PasteSpecial xlPasteFormats
Application.CutCopyMode = 0
With F2.Rows("1:" & derlig)
    .Columns(1).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(1) = "=1/(SUMPRODUCT(N(RC[6]:RC[14]<>0))=9)"
    .Columns(1) = .Columns(1).Value 'supprime les formules
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
    .Columns(1).Delete xlToLeft 'supprime la colonne auxiliaire
End With
F2.Columns.AutoFit 'ajustement largeurs
F2.Activate
F2.[A1].Select
End Sub

La macro est très rapide grâce au tri de regroupement.

Dadi147 · 14 Février 2023

job75 à dit:

Pas bien clair le "souvent" mais bon considérons que les cellules vides sont des valeurs nulles :

VB:

Sub CopyData()
Dim F1 As Worksheet, derlig&, F2 As Worksheet
Set F1 = Sheets("Sheet1")
If F1.FilterMode Then F1.ShowAllData 'si la feuille est filtrée
derlig = F1.Range("D" & F1.Rows.Count).End(xlUp).Row
Set F2 = Sheets("Résultat")
Application.ScreenUpdating = False
F2.Cells.Delete 'RAZ
F1.Rows("1:" & derlig).Copy
F2.[A1].PasteSpecial xlPasteValues
F2.[A1].PasteSpecial xlPasteFormats
Application.CutCopyMode = 0
With F2.Rows("1:" & derlig)
    .Columns(1).Insert xlToRight 'insère une colonne auxiliaire
    .Columns(1) = "=1/(SUMPRODUCT(N(RC[6]:RC[14]<>0))=9)"
    .Columns(1) = .Columns(1).Value 'supprime les formules
    .Sort .Cells(1), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
    On Error Resume Next 'si aucune SpecialCell
    .Columns(1).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
    .Columns(1).Delete xlToLeft 'supprime la colonne auxiliaire
End With
F2.Columns.AutoFit 'ajustement largeurs
F2.Activate
F2.[A1].Select
End Sub

La macro est très rapide grâce au tri de regroupement.

Merci beaucoup. C'est ce à quoi nous sommes toujours habitués de votre part. 👍

job75 · 14 Février 2023

Je pense que vous avez bien vu que mapomme et moi n'avons pas compris la même chose.

mapomme · 14 Février 2023

job75 à dit:
Je pense que vous avez bien vu que mapomme et moi n'avons pas compris la même chose.

Bonjour @job75 🙂,

Effectivement j'avais mal compris 🙁.

job75 · 14 Février 2023

mapomme à dit:
Effectivement j'avais mal compris 🙁.

Pas forcément car la question n'est pas bien claire.

Dadi147 · 14 Février 2023

mapomme à dit:
Bonjour @job75 🙂,

Effectivement j'avais mal compris 🙁.

Merci. Je viens de comprendre le code, même si ce n'était pas ma demande. Cependant, c'était une excellente solution que j'ai pu mettre en œuvre dans un autre fichier. Merci beaucoup.

mapomme · 14 Février 2023

Re @Dadi147 😉 ,

Dadi147 à dit:
même si ce n'était pas ma demande. [...] solution que j'ai pu mettre en œuvre dans un autre fichier

Et comme dit le proverbe : "à quelque chose malheur est bon" 😜.

XL 2019 Copier d'une feuille à l'autre en ignorant la valeur zéro

Dadi147

XLDnaute Occasionnel

job75

mapomme

XLDnaute Barbatruc

Pièces jointes

Dadi147

XLDnaute Occasionnel

Dadi147

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Dadi147

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Dadi147

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Dadi147

XLDnaute Occasionnel

mapomme

XLDnaute Barbatruc

Discussions similaires

XL 2019 Copier d'une feuille à l'autre en ignorant la valeur zéro

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency