Code pour ne pas copier les lignes vides

Le 30/06/2022 à 08:22

Bonjour, pouvez vous m'aider sur cette macro?

Elle fonctionne parfaitement, je souhaite juste ajouter le code pour ne pas copier les lignes vides dans ma sélection.

Range("D14:I26").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("simulation").Select
Range("A16").Select
Selection.Insert Shift:=xlDown
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End Sub

Edit modo : merci de mettre le code entre balises avec le bouton </>

merci de votre aide !

Nadege

Le 30/06/2022 à 09:56

Bonjour,

J'ai pas bien compris ton souhaite, peut être si tu joints le fichier te répondre serait plus simple.

Mais un petite piste :Sub

Dim Cel As Range  
For Each Cel In Range("D14:I26")    
 If Cel.Value <> "" Then ' test si la cellule à une valeur non nul
'mettre le code
End If
 End For

En gros, la marco va tester la valeur de chaque cellule, si la valeur est non nulle (cellule non vide) le code que tu mettras à la suite se lancera

Le 30/06/2022 à 10:14

Bonjour Nadège,

Pourriez-vous nous dire quelle version d'excel vous utilisez ?

Le 30/06/2022 à 10:15

Bonjour,

ci-dessous une proposition :

Sub test()
    Dim ligne As Range, à_copier As Range

    For Each ligne In Range("D14:I26").Rows
        If Not ligne.Find("*") Is Nothing Then
            If à_copier Is Nothing Then Set à_copier = ligne _
            Else Set à_copier = Union(à_copier, ligne)
        End If
    Next ligne
    If à_copier Is Nothing Then Exit Sub

    à_copier.Copy
    Sheets("simulation").Range("A16").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

End Sub
Le 30/06/2022 à 10:22

Bonjour,

un essai:

Sub copiePlageCellules()
transfereLignesNonVides Range("D14:I26"), Range("A1")
End Sub

Sub transfereLignesNonVides(PlageSource As Range, CelluleCible As Range)
Dim tabSansLigneVide As Variant, tabSource As Variant
Dim LignesNonVides As New Collection
Dim ligneTableau As Long

'initialisations
tabSource = PlageSource.Value

'boucle sur les lignes
For i = LBound(tabSource, 1) To UBound(tabSource, 1)
    If Not ligneVide(tabSource, i) Then
        LignesNonVides.Add i
    End If
Next i

'transfert des lignes vide dans un tableau pour export
If LignesNonVides.Count > 0 Then
    ReDim tabSansLigneVide(1 To LignesNonVides.Count, 1 To UBound(tabSource, 2))

    ligneTableau = 0
    For Each ligne In LignesNonVides
        ligneTableau = ligneTableau + 1

        For j = LBound(tabSource, 2) To UBound(tabSource, 2)
            tabSansLigneVide(ligneTableau, j) = tabSource(ligne, j)
        Next j
    Next ligne

    'export du résultat
    CelluleCible.Resize(UBound(tabSansLigneVide, 1), UBound(tabSansLigneVide, 2)).Value = tabSansLigneVide
End If
End Sub

Function ligneVide(tableau As Variant, ByVal ligne As Integer) As Boolean
Dim estVide As Boolean

'valeur par défaut
estVide = True

'vérification de la ligne
For j = LBound(tableau, 2) To UBound(tableau, 2)
    If Not tableau(ligne, j) = "" Then
        estVide = False
        Exit For
    End If
Next j

ligneVide = estVide
End Function
Le 30/06/2022 à 10:50

Bonjour à tous,

Sujet passionnant à priori

Une autre possibilité si la colonne "J" ne contient aucune donnée

Sub CopierLigneNonVide()
  Dim Lig As Long, NbLig As Long
  Application.ScreenUpdating = False
  ' Avec la feuille active
  With ActiveSheet
    ' Ajouter une formule en colonne J si vide
    .Range("J14:J26").FormulaLocal = "=NBVAL(D14:I14)"
    ' Filter les lignes dont le nombre de valeurs > 0
    With .Range("D14:J26")
      .AutoFilter
      .AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
    End With
    ' Compter le nombre de ligne visible
    For Lig = 14 To 26
      If .Range("D" & Lig).EntireRow.Hidden = False Then NbLig = NbLig + 1
    Next Lig
  End With
  ' Avec la feuille de simulation
  With Sheets("simulation")
    ' Insérer le nombre de lignes nécessaires
    .Range("A16:A" & 16 + NbLig).Insert Shift:=xlDown
    ' Copier les lignes filtrées
    ActiveSheet.Range("D14:I26").Copy
    ' Coller les valeurs
    .Range("A16").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
  End With
  With ActiveSheet
    .Range("D14:J26").AutoFilter
    .Range("J14:J26").ClearContents
  End With
  Application.ScreenUpdating = True
End Sub

A+

Le 30/06/2022 à 12:23

Et moi qui pensais que cela serait tout simple, qu'il suffisait juste de rajouter une petite ligne

Merci pour toutes vos réponses, je vais faire des essais et vous tiens au jus !

très bonne journée

Le 30/06/2022 à 14:28

bonjour,

plus court ??? (version définitif est pour ce soir)

Sub Macro1()
     a = Range("D14:I26").Value
     ReDim a1(1 To UBound(a))
     For i = 1 To UBound(a)
          a1(i) = IIf(Len(Join(Application.Index(a, i, 0), "")), i, "~")
     Next
     fl = Filter(a1, "~", 0)
     If UBound(fl) > -1 Then
          fl1 = Application.Transpose(fl)
          a2 = Application.Index(a, fl1, Array(1, 2, 3, 4, 5, 6))
          Sheets("simulation").Range("A16").Resize(UBound(a2), UBound(a2, 2)).Value = a2
     End If
End Sub
Le 01/07/2022 à 10:14

Bonjour à tous,

j'ai bien pris le temps d'essayer et toutes vos propositions ne fonctionnent pas.

Peut être est ce dû aux formules dans les cellules vides ?

Le 01/07/2022 à 10:20

bonjour,

la code originale contenait "Selection.PasteSpecial Paste:=xlPasteValues", donc des formules ne sont pas collé.

Donc les proposition fonctionnent bien, la question était douteux. C'est mieux d'ajouter un fichier.

Le 01/07/2022 à 11:01
BsAlv a écrit :

bonjour,

la code originale contenait "Selection.PasteSpecial Paste:=xlPasteValues", donc des formules ne sont pas collé.

Donc les proposition fonctionnent bien, la question était douteux. C'est mieux d'ajouter un fichier.

En effet il n'était pas question de formules...

Un essai de modification:

Sub copiePlageCellules()
transfereLignesNonVides Range("D14:I26"), Range("A1")
End Sub

Sub transfereLignesNonVides(PlageSource As Range, CelluleCible As Range)
Dim tabSansLigneVide As Variant, tabSource As Variant
Dim LignesNonVides As New Collection
Dim ligneTableau As Long

'initialisations
tabSource = PlageSource.Formula

'boucle sur les lignes
For i = LBound(tabSource, 1) To UBound(tabSource, 1)
    If Not ligneVide(tabSource, i) Then
        LignesNonVides.Add i
    End If
Next i

'transfert des lignes vide dans un tableau pour export
If LignesNonVides.Count > 0 Then
    ReDim tabSansLigneVide(1 To LignesNonVides.Count, 1 To UBound(tabSource, 2))

    ligneTableau = 0
    For Each ligne In LignesNonVides
        ligneTableau = ligneTableau + 1

        For j = LBound(tabSource, 2) To UBound(tabSource, 2)
            tabSansLigneVide(ligneTableau, j) = tabSource(ligne, j)
        Next j
    Next ligne

    'export du résultat
    CelluleCible.Resize(UBound(tabSansLigneVide, 1), UBound(tabSansLigneVide, 2)).Formula = tabSansLigneVide
End If
End Sub

Function ligneVide(tableau As Variant, ByVal ligne As Integer) As Boolean
Dim estVide As Boolean

'valeur par défaut
estVide = True

'vérification de la ligne
For j = LBound(tableau, 2) To UBound(tableau, 2)
    If Not tableau(ligne, j).Formula = "" Then
        estVide = False
        Exit For
    End If
Next j

ligneVide = estVide
End Function

J'ai remplacé Value par Formula, les formules qui ne renvoient rien seront prises en compte et copiées.

Le 01/07/2022 à 11:43

Bonjour NadegeEP

NadegeEP a écrit :

Bonjour à tous,

j'ai bien pris le temps d'essayer et toutes vos propositions ne fonctionnent pas.

Peut être est ce dû aux formules dans les cellules vides ?

Si le problème persiste, merci de joindre un fichier à ce fil SVP

Rechercher des sujets similaires à "code pas copier lignes vides"