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

Dadi147

XLDnaute Occasionnel
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
 
Solution
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

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

  • Dadi147- copie sans ligne vide- v1.xlsm
    21.5 KB · Affichages: 8
Dernière édition:

Dadi147

XLDnaute Occasionnel
Merci. Expérimentation en cours
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Classeur(1).xlsm
    18.7 KB · Affichages: 10

Dadi147

XLDnaute Occasionnel
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. 👍
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées