Copier des lignes jusqu'à la dernière non vide sous conditions

[momo]

Bonjour à tous

je voudrais savoir si il était possible que sur la feuille Etat de mon fichier Excel, qu'une macro à chaque fois qu'elle voit dans la colonne A "Unités Livrées"; qu'elle copie les infos sur toute la ligne suivante jusqu'à la dernière cellule non vide sur la feuille Résultat.
J'ai mis des couleurs identiques sur chacune des deux feuilles pour donner un effet visuel beaucoup plus parlant

Merci d'avance

 

[job75]

Re : Copier des lignes jusqu'à la dernière non vide sous conditions

Bonjour momo,

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Activate()
'le repère en colonne A est utilisé par la MFC
Dim titre$, t, ncol, rest(), i&, repere As Boolean, n&, j%
titre = "Unités Livrées"
With Sheets("Etat").UsedRange
  t = .Resize(.Rows.Count + 1) 'une ligne (vide) en plus
End With
ncol = UBound(t, 2) + 1 'une colonne en plus pour le repère
ReDim rest(1 To UBound(t), 1 To ncol)
i = 1
For i = i To UBound(t)
  If t(i, 1) = titre Then
    repere = Not repere 'alternance
    While t(i + 1, 1) <> ""
      i = i + 1
      n = n + 1
      rest(n, 1) = repere
      For j = 1 To ncol - 1
        rest(n, j + 1) = t(i, j)
      Next j
    Wend
  End If
Next i
If n Then [A2].Resize(n, ncol) = rest
Rows(n + 2 & ":" & Rows.Count).Delete
End Sub

A+

 

[momo]

Re : Copier des lignes jusqu'à la dernière non vide sous conditions

Fantastic!!!!! Merci Job!!!!

Je vous devrai une bière next time!!!

 

[job75]

Re : Copier des lignes jusqu'à la dernière non vide sous conditions

Re,

Si on limite le nombre de colonnes à copier (8) la macro est évidemment plus rapide :

Private Sub Worksheet_Activate()
'le repère en colonne A est utilisé par la MFC
Dim titre$, ncol%, t, rest(), i&, repere As Boolean, n&, j%
titre = "Unités Livrées" 'à adapter
ncol = 8 'nombre de colonnes à copier, à adapter
With Sheets("Etat").UsedRange
  t = .Resize(.Rows.Count + 1, ncol) 'une ligne (vide) en plus
End With
ReDim rest(UBound(t), ncol) 'base 0, une colonne en plus pour le repère
For i = 1 To UBound(t)
  If t(i, 1) = titre Then
    repere = Not repere 'alternance
    While t(i + 1, 1) <> ""
      i = i + 1
      rest(n, 0) = repere
      For j = 1 To ncol
        rest(n, j) = t(i, j)
      Next j
      n = n + 1
    Wend
  End If
Next i
If n Then [A2].Resize(n, ncol + 1) = rest
Rows(n + 2 & ":" & Rows.Count).Delete
End Sub

Notez que le tableau rest est en base 0, c'est mieux.

Fichier (2).

A+

 

[momo]

Re : Copier des lignes jusqu'à la dernière non vide sous conditions

Perfect!!!!! Merci Beaucoup!!!! Sur plusieurs lignes cette version aide vraiment beaucoup!!!