Macro condition

Question

Bonjour,
je suis en train d'élaborer une macro copier/coller avec condition. J'ai réussi à élaborer le copier/coller avec une condition mais qui ne correspond pas au résultat final attendu.
Voici ma macro : Cette macro copie les données d'un tableau de la feuille 1 à la feuille 2, en prenant sélectionnant les lignes dont la cellule de la colonne 2 contient un "1". Par contre, moi je souhaite faire cela sur une plge. C'est à dire copier les lignes dont les chiffres de la colonne 2 sont compris entre 1 et 100. 

Sub TransfertDonnees()
'
Dim Cellule As Range
Dim PremiereAdresse As String
Dim LigneDest As Long
'
    Sheets("Feuil1").Select
    Columns(2).Select

    LigneDest = Sheets("Feuil2").Range("A65536").End(xlUp).Row + 1

    Set Cellule = Selection.Inf("1")
    
    If Not Cellule Is Nothing Then
        PremiereAdresse = Cellule.Address
        Do
            Cellule.EntireRow.Copy Sheets("Feuil2").Cells(LigneDest, 1)
            LigneDest = LigneDest + 1
            Set Cellule = Selection.FindNext(Cellule)
    Loop Until Cellule.Address = PremiereAdresse
    End If
End Sub

Je n'arrive pas à faire évoluer ma macro dans ce sens. Merci pour votre aide.

Mike-31 · Answer

Salut,

Testes cette macros que j'ai adapté pour un transfert de données feuille1 pour des valeurs comprise entre 1 et 100 en collé à la suite sur la feuille2

Sub TransfertDonnees()
'
Dim Lig As Long
    Dim LigFinA As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim LigFin As Long
    Sheets("Feuil2").Activate
    Col = "B"
    LigFin = Range("A65536").End(xlUp).Row + 1
    NumLig = 1
    With Sheets("Feuil1")
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
        If .Cells(Lig, Col).Value >= 1 Then
        If .Cells(Lig, Col).Value <= 100 Then
          .Cells(Lig, Col).EntireRow.Copy
          NumLig = NumLig + 1
            Cells(LigFin, 1).Select
            LigFin = LigFin + 1
            ActiveSheet.Paste
            End If
            End If
    Next
    End With
    Application.CutCopyMode = False
MsgBox ("TRANSFERT EFFECTUE")
End Sub

A+
Mike-31

Un problème sans solution est un problème mal posé  (Einstein)

Mike-31 · Answer

Re,

Rapidement j'ai monté un exemple à récupérer avec le lien ci-dessous, j'ai modifié le code qui efface la feuille 2 avant de transférer les données. Si c'est ce que tu cherches, en fin d'après midi je reverrais le code pour le simplifier

https://www.cjoint.com/?kioDdKbLh4

A+
Mike-31

Un problème sans solution est un problème mal posé  (Einstein)

popey301 · Answer

Re,
Merci beaucoup pour ce travail...c'est exactement ce que je cherchais....
Impeccable, je l'ai appliqué sur mon support en adaptant quelques bricoles (noms de feuilles, emplacement de cellules)...
Thanks

Mike-31 · Answer

Re,

Il est possible d'alléger un peu le code, 
Si le code te convient, n'oublies pas de mettre ton statut en résolu

Sub TransfertDonnees()
'
Dim Lig As Long
    Dim LigFinA As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim LigFin As Long
    [Feuil2].Activate
    LigFin = [A65536].End(xlUp).Select
    Range(activecell(), [C2]).ClearContents
    Col = "B"
    LigFin = [A2].Row + 1
    NumLig = 1
    With [Feuil1]
    NbrLig = .Cells(65536, Col).End(xlUp).Row
    For Lig = 1 To NbrLig
        If .Cells(Lig, Col).Value >= 1 Then
        If .Cells(Lig, Col).Value <= 100 Then
          .Cells(Lig, Col).EntireRow.Copy
          NumLig = NumLig + 1
            Cells(LigFin, 1).Select
            LigFin = LigFin + 1
            ActiveSheet.Paste
            End If
            End If
    Next
    End With
    Application.CutCopyMode = False
MsgBox ("TRANSFERT EFFECTUE")
End Sub

A+
Mike-31

Un problème sans solution est un problème mal posé  (Einstein)

Macro condition

4 réponses

Discussions similaires

Newsletters