Probleme avec ma macro

Bonjour Hugo
Essaie la macro ci-dessous. Note qu'il peut etre judicieux de tester si MonCritere n'est
pas vide pour eviter une erreur.

j-p

Sub SelectionNC()
Dim MonCritere

Set bbb = ActiveWorkbook
For i = 1 To 5
MonCritere = bbb.Worksheets("Feuil3").Range("A" & i).Value 'definition de mon critere

Set aaa = Workbooks.Add 'creation d'1 nouveau classeur
aaa.SaveAs Filename:=MonCritere
cpt = 1
For j = 1 To 100
If bbb.Worksheets("feuil2").Range("A" & j).Value = MonCritere Then
bbb.Worksheets("feuil2").Range("A" & j).EntireRow.Copy
Destination:ªa.Worksheets("Feuil1").Range("a" & cpt)
cpt = cpt + 1
End If
Next
aaa.Close True
Next i
Set aaa = Nothing
Set bbb = Nothing
End Sub

Bonjour Hugo,

'-----------------------------------------
Sub test()

Dim Critère As Variant, Adr As String
Dim Rg As Range, Trouve As Range
Dim Wk As Workbook, A As Long

With Worksheets("Feuil3")
Critère = .Range("A1").Text
End With
If Critère = "" Then Exit Sub
Application.ScreenUpdating = False
Set Wk = Workbooks.Add

With ThisWorkbook.Worksheets("Feuil2")
Set Rg = .Range("A1:C" & .Range("A65536").End(xlUp).Row)
With Rg
Set Trouve = .Find(Critère, , LookIn:=xlFormulas, _
lookat:=xlWhole, SearchOrder:=xlByRows)
If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
A = A + 1
.Item(Trouve.Row, 1).EntireRow.Copy Wk.Worksheets(1).Range("A" & A)
Set Trouve = .Find(Trouve, .Item(Trouve.Row, .Columns.Count))
Loop While Not Trouve Is Nothing And Trouve.Address <> Adr
If A = 0 Then Wk.Close False
Wk.SaveAs ThisWorkbook.Path & "" & Critère & ".xls"
End If
End With
End With

End Sub
'-----------------------------------------


Salutations!



"hugo" <hugo@discussions.microsoft.com> a écrit dans le message de news: 351B5761-1F42-42D3-B8BA-4AEBCC123D68@microsoft.com...
bonjour a tous,
j'ai essaye de mettre sur pied une macro qui:
A partir d'un critere se trouvant dans la feuille3 de mon classeur.
Va selectionner les lignes qui repondent a celui-ci dans la feuille2 de mon
classeur.
Va creer un nouveau classeur avec comme nom celui du critere
et copier les lignes selectionnées dans celui-ci.
Mais mahleuresement ma macro ne fonctionne pas,pourriez -vous m'aider et
m'indiquer les modifs à effectuer.
Merci d'avance pour votre aide.
Hugo

voici le code:
Sub SelectionNC()
Dim MonCritere
For i = 1 To 10
MonCritere = Worksheets("Feuil3").Range("A" & i).Value 'definition de mon
critere

N = 1 'boucle pour selectionner les lignes correspondant a mon critere
NombreLignes = 100 'nbre de lignes toale de ma feuille2
While i < NombreLignes + 1
If Worksheets("Feuil2").Range("A" & N).Value = MonCritere Then
MesLignes = MesLignes & N & ":" & N & ","
End If
N = N + 1
Wend
MesLignes = Left(MesLignes, Len(MesLignes) - 1)
Sheets("Feuil2").Range(MesLignes).Select

Set aaa = Workbooks.Add 'creation d'1 nouveau classeur
aaa.SaveAs Filename:=MonCritere
Selection.Copy
Destination:=Workbooks("MonCritere").Worksheets("Feuil1").Range("A1")

Next i
' apres execution j'esperais la creation de 10 nouveaux classeurs mais pas
de miracle!!!! il ya un bug

End Sub

bonjour jp
merci pour ton aide ;ta macro fonctionne du tonnere juste en supprimant
l'instruction Set bbb = Nothing
a+ et encore merci

Bonjour Hugo
Essaie la macro ci-dessous. Note qu'il peut etre judicieux de tester si MonCritere n'est
pas vide pour eviter une erreur.

j-p

Sub SelectionNC()
Dim MonCritere

Set bbb = ActiveWorkbook
For i = 1 To 5
MonCritere = bbb.Worksheets("Feuil3").Range("A" & i).Value 'definition de mon critere

Set aaa = Workbooks.Add 'creation d'1 nouveau classeur
aaa.SaveAs Filename:=MonCritere
cpt = 1
For j = 1 To 100
If bbb.Worksheets("feuil2").Range("A" & j).Value = MonCritere Then
bbb.Worksheets("feuil2").Range("A" & j).EntireRow.Copy
Destination:ªa.Worksheets("Feuil1").Range("a" & cpt)
cpt = cpt + 1
End If
Next
aaa.Close True
Next i
Set aaa = Nothing
Set bbb = Nothing
End Sub