Maccro sans erreurs mais qui ne fait rien (Cop/col entre 2 classeurs sous conditions)

[guil456]

Bonjour ami Excelleur!

Voici mon problème, ma maccro doit copier un range si en colonne A il y a quelquechose d'écrit alors ça doit sélectionner le range et le mettre dans un nouveau classeur.
La création du classeur nouveau fonctionne avec saveas, la maccro s'exécute mais rien ne se copie.

je dois parcourir toutes les feuilles du classeur A et si dans une feuille, la colonne A n'est pas vide alors je dois copier et mettre dans classeur B en renommant la feuille "feuil1" du classeur B avec une formule et continuer.
Si dans A j'ai 8 feuilles avec qqc dans la colonne B, en théorie je devrais avoir 8 feuilles dans B. J'en suis pas encore là mais je ne comprends pas pourquoi ça ne marche pas pour le moment.

Voici la boucle qui s'exécute sans erreur mais sans résultat.

Sub Consulter()
Dim i As Integer
Dim s As Integer
Dim f As Integer
Dim r As Integer
i = 8
f = 4
r = 1

Dim nomClasseur
Dim vclasseur As Workbook


Set vclasseur = Workbooks.Add
nomClasseur = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls")

If (nomClasseur <> False) Or (nomClasseur <> "") Then
vclasseur.SaveAs Filename:=nomClasseur
End If
For s = 1 To Workbooks("ANNUAIRE ST.xls").Sheets.Count

While (Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Worksheets(s).Cells(i, 2).Text <> "")

If (Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Worksheets(s).Cells(i, 1).Text <> "") Then

Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Activate
Workbooks.Application.vclasseur.Worksheets(r).Cells(1, 1).Text = Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Worksheets(s).Range("C10").Text
Workbooks.Application.vclasseur.Worksheets(r).Name = Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Worksheets(s).Range("C10").Text
Workbooks.Application.Workbooks("ANNUAIRE ST.xls").Sheets(s).Range("B" & i & ":" & "J" & i + 2).Select
Selection.Copy
Workbooks.Application.vclasseur.Activate
Workbooks.Application.vclasseur.Worksheets(r).Range("A" & f & ":" & "I" & f + 2).Select
ActiveSheet.PasteSpecial Type:=xlPasteValuesAndNumberFormats
r = r + 1
End If

i = i + 3
f = f + 3
Wend

Next



End Sub

Merci pour votre aide, le fait qu'il n'y ait pas d'erreur m'empêche de trouver ce qui ne va pas...

Guillaume, Développeur en Herbe!

 

[guil456]

Re : Maccro sans erreurs mais qui ne fait rien (Cop/col entre 2 classeurs sous condit

Eurêka !
i = 8
f = 4
à mettre après le for pour le réinitialiser... Erf, parfois, même toujours, un petit détail met tout en vrac, c'est ce qui est le plus dur dans la programmation, je trouve! Maintenant mon if s'active j'ai des erreurs mais je vais pouvoir y remédier, enfin je l'espère!

 

[kjin]

Re : Maccro sans erreurs mais qui ne fait rien (Cop/col entre 2 classeurs sous condit

Bonsoir,
Avec ce que j'arrive à déchiffrer...

Sub Consulter()
Dim Q, i%, j%, T
Dim wbSource As Workbook, wbDest As Workbook
Set wbSource = ThisWorkbook
Set wbDest = Workbooks.Add
Q = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls")
If Q = False Or Q = "" Then Exit Sub
wbDest.SaveAs Q
With wbSource
    For j = 1 To .Sheets.Count
        Set ws = wbDest.Sheets.Add(after:=Sheets(Sheets.Count))
        With .Sheets(j)
            ws.Name = .Cells(10, 3)
            For i = 8 To .Range("A65000").End(xlUp).Row Step 3
                If .Cells(i, 1) <> "" And .Cells(i, 2) <> "" Then
                    T = .Range(.Cells(i, 2), .Cells(i + 2, 10)).Value
                    ws.Cells(i - 4, 1).Resize(UBound(T, 1), UBound(T, 2)) = T
                End If
            Next
        End With
    Next
End With
End Sub

A+
kjin