Macro condition
Popey301
Messages postés
2
Statut
Membre
-
Mike-31 Messages postés 19572 Date d'inscription Statut Contributeur Dernière intervention -
Mike-31 Messages postés 19572 Date d'inscription Statut Contributeur Dernière intervention -
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.
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.
A voir également:
- Macro condition
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Excel cellule couleur si condition texte - Guide
- Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Jitbit macro recorder - Télécharger - Confidentialité
- Excel condition ou - Guide
4 réponses
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)
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)
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)
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)
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
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
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)
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)
Merci pour l'intérêt porté à ma demande.
Je n'arrive pas à applique ceci sur mon fichier. J'ai l'impression qu'il reste sur la feuille 2 sur laquelle, il fait des copiers/coller de lignes mais ne se base pas sur les données de la feuille 1.
Mon besoin est d'utiliser les données de la feuille 1 et copier/coller la ligne sur la feuille 2 en fonction du contenu de la colonne B (copier/collers si la valeur dans la cellule est comprise entre 1 et 100).
Exemple de données sur la feuille 1 (feuille 2 initialement vide) :
Colonne A Colonne B Colonne C
Heure1... 100 Texte.....
Heure2... 20 Texte.....
Heure 3... 200 Texte....
Dans cet exemple, l'idée est de retrouver sur ma feuille 2 uniquement les lignes avec des données comprises entre 1 et 100, soit les lignes 1 et 2.