Double condition et action dans une macro
Bonjour,
J'ai la macro suivante qui recherche un mot dans une colonne et lorsqu'il trouve ce mot réalise une série d'action.
Avant sa dernière action qui est de supprimer la ligne, je souhaiterais qu'il réalise sur une cellule précise de la ligne sur laquelle il s'est arrêté (celle de la colonne I) également une recherche d'un mot. S'il est présent, une action sera également à réaliser avant de terminer la macro initial.
Sub Encodage()
Dim cell As Range, lig%
Sheets("Encodage").Activate
Application.ScreenUpdating = False
For Each cell In Sheets("Encodage").Range("O3:O" & Sheets("Encodage").Range("O65536").End(xlUp).Row)
If cell.Value = "ruche 1" Then
lig = cell.Row
Sheets("Ruche 1").Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Encodage").Range(Cells(lig, "A"), Cells(lig, "N")).Copy Destination:=Sheets("Ruche 1").Rows(5)
Sheets("Encodage").Range(Cells(lig, "A"), Cells(lig, "O")).ClearContents
End If
Next
Application.ScreenUpdating = True
End Sub
Et voici la 2ème macro que j'aimerai appliquer à la ligne trouvée lors de la première avant l'exécution de la dernière ligne ClearContents
Dim cell As Range, lig%
Sheets("Encodage").Activate
Application.ScreenUpdating = False
For Each cell In Sheets("Ruche 1").Range("I...........") 'Je ne sais pas comment lui indiquer qe c'est la cellule de la colonne I mais de la ligne sur laquelle il vient de s'arrêter
If cell.Value = "H1" Then
lig = cell.Row
Sheets("Encodage").Range("I........").Copy Destination:=Sheets("Matériel").Range("B2")
Merci
Salut Dedudelefabs,
Prends les bonnes habitudes pour nous aider à t'aider :
- joins un fichier à ta demande que nous puissions visualiser le problème et tester nos solutions ;
- dans tes messages, utilise la balise </> (barre d'outils au-dessus de la fenêtre d'édition du message) pour y coller un code.
A tester puisque... pas de fichier!
Sub Encodage()
'
Dim sWk As Worksheet, rCel As Range, iRow%
'
Application.ScreenUpdating = False
'
With Sheets("Encodage")
On Error Resume Next
Set rCel = .Range("O3:O" & .Range("O" & Rows.Count).End(xlUp).Row).Find(what:="ruche 1", lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext)
If Not rCel Is Nothing Then
Set sWk = Worksheets(CStr(rCel.Value))
iRow = rCel.Row
sWk.Rows(5).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A" & iRow & ":N" & iRow).Copy Destination:=sWk.Rows(5)
If .Range("I" & iRow).Value = "H1" Then Worksheets("Matériel").Range("B2").Value = "H1"
.Range("A" & iRow & ":O" & iRow).ClearContents
End If
On Error GoTo 0
End With
'
Application.ScreenUpdating = True
'
End SubSi tu veux en réalité DELETE la ligne iRow plutôt que simplement effacer les données, c'est comme ceci :
.Rows(iRow).Delete shift:=xlUpA+
Super, merci !!!
Ca fonctionne super !!!
Salut Dedudelefabs,
Trois choses avant de démarrer la macro :
- je postule que les feuilles attendues sont déjà créées ;
- les lignes effacées dans 'Encodage' ne devraient-elles pas être éliminées ? Tout ça laisse des lignes vides, ce qui n'est guère efficace...
- dans cette version, tu mentionnes une valeur en colonne [K] dont tu ne parlais pas dans la version précédente : faute de frappe ou réalité ?
Public Sub Encodage()
'
Dim sWk As Worksheet, rCel As Range, iRow%, iIdx%
'
Application.ScreenUpdating = False
'
With Sheets("Encodage")
On Error Resume Next
For x = 1 To 39
Set rCel = .Range("O3:O" & .Range("O" & Rows.Count).End(xlUp).Row).Find(what:="ruche " & CStr(x), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext)
If Not rCel Is Nothing Then
iRow = rCel.Row
Set sWk = Worksheets(CStr(rCel.Value))
sWk.Rows(5).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
sWk.Range("A5:N5").Value = .Range("A" & iRow & ":N" & iRow).Value
If Left(.Range("I" & iRow).Value, 1) = "H" Then
iIdx = CInt(Split(.Range("I" & iRow).Value, "H")(1))
Worksheets("Matériel").Range("B" & iIdx + 1).Value = "H" & CStr(iIdx)
End If
.Range("A" & iRow & ":O" & iRow).ClearContents
End If
Next
On Error GoTo 0
End With
'
Application.ScreenUpdating = True
'
End SubA tester sur une copie de ton fichier de travail !
A+
Slt,
- Les feuilles attendues sont déjà crées
- l’action avec la colonne K est une réalité que j’ai ajouté à ta macro d’hier
Je testerai demain. En attendant j’ai divisé mon immense macro en 10 petites que je lance par une Macro et la fonction Call pour appeler chacune successivement. Bcp moins propre et programmateur je te l’accorde mais pour un béotien comme moi ça...
Je te dis quoi
J’ai aussi un autre projet dont j’aimerai te parler pour finaliser mon ficher de gestion d’apiculture.
Je souhaiterais sur chacune de mes fiches ruche effectuer une automatisation d’agenda. J’ai une colonne donnée appelée « activité à prévoir » suivie d’une colonne avec date. J’aimerais une macro qui si elle trouve une date dans la colonne date, copie le texte de la colonne activité à prévoir à côté puis e rende sur une page agenda ou j’ai un planning par mois et copie au jour donné l’activité à prévoir en spécifiant de quelle page cela vient ex. En date de 10 janvier avoir : ruche 1 Surveiller présence de la reine.
Ça te paraît faisable ?
Je te Feed back demain pour la macro d’Andrimont
Dors et déjà MERCI
Salut
pas sommeil...
Macro adaptée aux actions en colonne [I:K].
Elle boucle tes 39 ruches et traite tes "H xxx".
Tu ne m'as toujours pas précisé si les lignes vides devaient rester en place ou être éliminées !!
Public Sub Encodage()
'
Dim sWk As Worksheet, rCel As Range, iRow%, iIdx%
'
Application.ScreenUpdating = False
'
With Sheets("Encodage")
On Error Resume Next
For x = 1 To 39
Set rCel = .Range("O3:O" & .Range("O" & Rows.Count).End(xlUp).Row).Find(what:="ruche " & CStr(x), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext)
If Not rCel Is Nothing Then
iRow = rCel.Row
Set sWk = Worksheets(CStr(rCel.Value))
sWk.Rows(5).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
sWk.Range("A5:N5").Value = .Range("A" & iRow & ":N" & iRow).Value
For y = 1 To 2
iIdx = IIf(Left(.Range(Choose(y, "I", "K") & iRow).Value, 1) = "H", CInt(Split(.Range(Choose(y, "I", "K") & iRow).Value, "H")(1)), 0)
If iIdx > 0 Then Worksheets("Matériel").Range("B" & iIdx + 1).Value = IIf(y = 1, "", "H" & CStr(iIdx))
Next
.Range("A" & iRow & ":O" & iRow).ClearContents
End If
Next
On Error GoTo 0
End With
'
Application.ScreenUpdating = True
'
End SubA+
Salut
Alors sans voulait être chiant sur les 39 ruches j’ai en fait 24 ruche appelée ruche pour lesquelles je cherche une valeur H allant de H1 à H72 qui copie ou effacé dans la colonne B et C de 2 à 51 de magasin et j’ai 15 ruchettes appelées ruchettes de ruchettes 1 a ruchette 15 ou je cherche non pas le terme H mais HM de HM 1 a HM 30 dans la colonne E et F de 2 à 51 de magasin
Pour ce qui est de la ligne a effacé je ne te comprend pas, on l’efface et elle est à nouveau dispo pour pouvoir re encoder. Que veux tu faire de plus ?
As tu réfléchi pour mon problème d’agenda si c’est possible ?
En tout cas MERCI BEAUCOUP ! Impossible de trouver un programme adapté à l’activité apicole dans le commerce donc je suis obligé de me le créer
Ci joint mon fichier ça sera plus simple
Voila, j'ai testé et ca ne fonctionne pas complètement.
La partie qui identifie le terme ruche puis ajoute une liche sur la page ruche et y copie la ligne en cours puis efface la ligne de la page encodage fonctionne et j'ai même réussi à le faire pour mes ruchettes
Ce qui ne fonctionne pas c'est l'identification du terme H avec soit la copie ou l'effacement du terme sur la page matériel
En plus pour cette phase, il faut identifier H pour les ruches ou HM pour les ruchettes et ce sur 2 colonne. La BC pour H et la EF pour HM.
Tu vois ce qui peux clocher avec le fichier que je t'ai envoyé ?
Merci