XL 2016 selection des lignes superieur à zero pour copier coller

davidp

XLDnaute Occasionnel
Bonjour le forum ,

Désolé de vous déranger , je suis à la recherche d'une macro
qui sélectionnerait uniquement les lignes supérieures à ZERO de la feuille "en cours" afin réaliser un copier coller dans la feuille "final" à partir de A2 .

Dans l'exemple : la plage à copier est de A2:B17

Un grand merci d'avance pour votre aide

DAVIDP
 

Pièces jointes

  • forum.xlsx
    45.2 KB · Affichages: 6

Dranreb

XLDnaute Barbatruc
Bonjour.
VB:
Option Explicit

Sub LaMacroDemandée()
ColLignesOùRelat(ThisWorkbook.Worksheets("EN COURS").[A2:B2], "A", "<>", 0).Copy _
   Destination:=ThisWorkbook.Worksheets("FINAL").[A2]
End Sub

Rem. Fonctions de service nécessaires :
Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
   On Error Resume Next
   Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, OPé, Valeur), CelDéb.EntireColumn)
   End Function
Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
   If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
   If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
      """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
   On Error Resume Next
   Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & OPé & Valeur)
   End Function
Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
   On Error Resume Next
   Set ColLignesOùCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
   End Function
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb vérifiant une condition R1C1 CondR1C1.
   Dim Rng As Range
   Set Rng = PlageÀPartirDe(LigneDéb.EntireRow): If Rng Is Nothing Then Exit Function
   Set Rng = Rng.Columns(Rng.Columns.Count + 1)
   Application.ScreenUpdating = False
   On Error Resume Next
   Rng.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
   Set LignesOùCondR1C1 = Rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow
   Rng.Delete xlShiftToLeft
   End Function
Function PlageÀPartirDe(ByVal CelDéb As Range) As Range
Rem. ——— Plage utilisée à partir de CelDéb.
   Dim NbrLig As Long, NBrCol As Long
   With CelDéb.Worksheet.UsedRange:
      NbrLig = .Row + .Rows.Count - CelDéb.Row
      NBrCol = .Column + .Columns.Count - CelDéb.Column
      If NbrLig <= 0 Or NBrCol <= 0 Then Exit Function
      End With
   Set PlageÀPartirDe = CelDéb.Resize(NbrLig, NBrCol)
   End Function
 

Dranreb

XLDnaute Barbatruc
Une autre macro possible utilisant uniquement la dernière fonction de service :
VB:
Sub UneAutreMacroPossible()
   PlageÀPartirDe(ThisWorkbook.Worksheets("Base").[A3]).Copy _
   Destination:=ThisWorkbook.Worksheets("FINAL").[A2]
   End Sub
Compliqué ? Une seule instruction ! (les modules et fonctions de service toutes faites ne comptent pas dans l'estimation de cette complexité. Ou alors c'est de la folie pure, puisqu'il faudrait logiquement y compter aussi toute la programmation invisible de toutes les bibliothèques en références, et je vous garantis qu'elle est bien plus compliquée que ça !)
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG