Macro copier/coller avec conditions s'arrête à la première valeur

Bonjour,

Je suis complètement novice en VBA et malgré de nombreuses recherches je ne parviens toujours pas à faire tourner une macro.

En piochant des infos sur les forums, j'ai pu écrire la macro ci-dessous mais elle ne fonctionne pas bien et je ne sais pas pourquoi.

L'objectif est, à partir du fichier de base ("Tr ano") :

  • Ouvrir un autre fichier excel "Shortg
  • enlever les filtres (pour être sûr que toutes les lignes soient analysées)
  • sur chaque ligne vérifier les infos dans les colonnes 40, 23 et 22
  • quand les conditions sont remplies -> copier uniquement les cellules et la colonne N et P de cette ligne
  • Coller les valeurs dans la première ligne vide des colonne M et N du fichier de base (Tr ano)
  • Ferme le fichier excel "Shortg"

La macros ci dessous me renvoient une valeur mais s'arrête à la première ligne vérifiant toutes les conditions.

Savez-vous où est mon erreur ?

Merci d'avance.

Dim NombreLigne As Integer

Dim Date_selec As String

Date_selec = InputBox("Date selec : c:Ruptures\Shortg.xlsx"

Workbooks("Shortages").Sheets("CROSSTAB_2").Activate

ActiveSheet.ShowAllData

NombreLigne = Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To NombreLigne

If Cells(i, 40) = "P" And Cells(i, 23) = "X" And Cells(i, 22) < Date_selec Then

Range(Cells(i, 14), Cells(i, 15)).Copy

Workbooks("Tr ano").Sheets("Data").Activate

Range("M65000").End(xlUp).Offset(1).Select

ActiveSheet.Paste

End If

Next

End Sub

Bonjour

Sans voir votre fichier, essayez comme ceci

Sub tes()
Dim Date_selec As String
Dim i As Long, dlg As Long

Date_selec = InputBox("Date selec : ")

Workbooks.Open Filename:="M:\SERVICES\GIL\Indicateurs\Ruptures\Shortages.xlsx"
Workbooks("Shortages").Sheets("CROSSTAB_2").Activate
ActiveSheet.ShowAllData

With Workbooks("Tr ano").Sheets("Data")
    dlg = .Range("M" & .Rows.Count).End(xlUp).Row + 1
End With

With Workbooks("Shortages").Sheets("CROSSTAB_2")

 For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
    If .Cells(i, 40) = "P" And .Cells(i, 23) = "X" And .Cells(i, 22) < Date_selec Then
      .Range(.Cells(i, 14), .Cells(i, 15)).Copy Workbooks("Tr ano").Sheets("Data").Range("M" & dlg)
    End If
 Next
End Sub

Le code est supposé être placé dans le fichier TR ANO

Notez aussi que colonnes 14 et 15, ce sont les colonnes N et O

Cordialement

Super merci pour votre rapidité !

La macro fonctionne mais elle ne renvoie qu'une seule ligne ( alors que plusieur remplisse les critères)

Une idée ?

Je pourrais vous envoyer des fichiers exemples ce soir

Merci d'avance !

Re

Oui c'est mieux avec les fichiers. Eviter le données confidentielles (nom, adresse, tel etc...)

Crdlt

Bonsoir,

Ci joint le fichier source avec les données et le fichier avec la macro,

merci de votre aide !

Cdlt,

Fabrice

2shortg.xlsx (161.48 Ko)
2tr-ano.xlsm (16.09 Ko)

Re

Essayez comme ceci :

Sub Test_ouverture_fichier()

Dim Date_selec As String
Dim i As Long, dlg As Long

Date_selec = InputBox("Date selec : ")
If Date_selec = "" Then MsgBox "Vous devez mettre une date !": Exit Sub
Workbooks.Open Filename:="C:\Users\SESA515474\Desktop\Shortg.xlsx"
Workbooks("Shortg").Sheets("CROSSTAB_2").Activate
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
With Workbooks("Tr ano").Sheets("Data")
    dlg = .Range("M" & .Rows.Count).End(xlUp).Row + 1
End With

With Workbooks("Shortg").Sheets("CROSSTAB_2")

 For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
    If .Cells(i, 21) = "S" And .Cells(i, 18) = "LA" And .Cells(i, 17) < Date_selec Then
      .Range(.Cells(i, 7), .Cells(i, 8)).Copy Workbooks("Tr ano").Sheets("Data").Range("M" & dlg)
      dlg = dlg + 1
    End If
Next i
End With
End Sub

Cordialement

Bonsoir,

Parfait la macro marche,

Merci beaucoup !

Rechercher des sujets similaires à "macro copier coller conditions arrete premiere valeur"