[VBA] Probleme emplacement macro Fermé

Question

bonjour à tous,

j'ai un probleme concernant une macro sous vba.
En fait, je ne sais pas bien à quel endroit l'enregistrer. Je m'explique:
cette macro enregistre les lignes sélectionnées d'une des  2 feuilles du classeur (la feuille active) ou des deux feuilles dans une autre version et les enregistre dans un nouveau classeur. 
Le probleme c'est que quand je place cette macro dans l'objet Feuil1 (à gauche en haut) ca ne l'éxécute QUE pour la feuille 1,  si je la place dans objet feuil2 ca ne l'éxécute QUE pour la feuille 2 et quand je la mets dans "this workbook", la ca ne me copie rien du tout et ca m'enregistre une nouvelle feuille vide, alors que des lignes sont sélectionnées.
J'ai un peu cherché et j'avoue que je ne comprends pas pourquoi ca fait ca.

Voici mon code :

Sub enregistrer()

Dim j As Integer 
j = 1            

Set NewSheet = Worksheets.Add

'boucle dans la feuille activée jusqu'a la derniere ligne
For i = 1 To ActiveSheet.Range("A2").End(xlDown).Row
'condition ligne colorée 
'si colorée, on copie la ligne dans la nouvelle feuille a partir de la premiere ligne
If Rows(i).Interior.ColorIndex = 33 Then
Rows(i).Copy
NewSheet.Range("A" & j).PasteSpecial Paste:=xlValues
j = j + 1  'incrément de j
End If
Next i

NewSheet.Copy
Nomfichier = Application.GetSaveAsFilename(fileFilter:="Classeur Excel (*.xls), *.xls")
ActiveWorkbook.SaveAs Filename:=Nomfichier, FileFormat:=xlWorkbookNormal

NewSheet.Delete

End Sub

J'espere que vous pourrez m'aider.
Merci d'avance.

Utilisateur anonyme · Answer

Bonjour,

À placer dans un module :


Sub Enregistrer()

    Const Destination = "Destination"
    Const Maitre = "MonFichier.xls"
    
    Dim j As Integer, i As Integer, Feuille As String
    Dim NomFichier As String
    
    j = 1
    Feuille = ActiveSheet.Name
    Worksheets.Add.Name = Destination
    
    Sheets(Feuille).Select
    'boucle dans la feuille activée jusqu'a la derniere ligne
    For i = 0 To (ActiveSheet.Range("A1:A65536").End(xlDown).Row - 1)
        'condition ligne colorée
        'si colorée, on copie la ligne dans la nouvelle feuille
        ' a partir de la premiere ligne
        If ActiveCell.Offset(i, 0).Interior.ColorIndex = 33 Then
            ActiveCell.Offset(i, 0).EntireRow.Copy
            Sheets(Destination).Range("A" & j).PasteSpecial Paste:=xlValues
            j = j + 1 'incrément de j
        End If
    Next i

    Sheets(Destination).Copy
    NomFichier = Application.GetSaveAsFilename(fileFilter:="Classeur Excel (*.xls), *.xls")
    ActiveWorkbook.SaveAs Filename:=NomFichier, FileFormat:=xlWorkbookNormal
    ActiveWorkbook.Close
    Application.DisplayAlerts = False
    Sheets(Destination).Delete
    Application.DisplayAlerts = True

End Sub
'

Lupin

fabriiice31 · Answer

Merci beaucoup Lupin pour ton aide précieuse (et rapide) bien que je ne comprenne toujours pas trop pourquoi cela ne marchait pas (j'ai oublié de préciser que j'avais également essayé de la placer dans un module sans succès!!)

Merci encore en tout cas

Fab

Utilisateur anonyme · Answer

re :

Quand j'ai du temps ... c'est un plaisirs que d'aider autrui, et oui je suis altruiste :-)

Pour te donner quelques idées sur le non-fonctionnement.


Sub enregistrer()

    Dim j As Integer

    j = 1

    Set NewSheet = Worksheets.Add
    ' L'instruction [ Worksheets.Add ] a le même effet que
    ' de dire [ ThisNewSheets.Select ]
    For i = 1 To ActiveSheet.Range("A2").End(xlDown).Row
        ' Donc le [ ActiveSheet ] dans la boucle For pointe
        ' sur la nouvelle feuille et non sur la source
        If Rows(i).Interior.ColorIndex = 33 Then
            ' Je n'ai jamais utiliser cette syntaxe et de plus
            ' le compilateur me génère une erreur -> [ Rows(i).Interior.ColorIndex ]
            Rows(i).Copy
            NewSheet.Range("A" & j).PasteSpecial Paste:=xlValues
            j = j + 1
        End If
    Next i

    NewSheet.Copy
    NomFichier = Application.GetSaveAsFilename(fileFilter:="Classeur Excel (*.xls), *.xls")
    ActiveWorkbook.SaveAs Filename:=NomFichier, FileFormat:=xlWorkbookNormal
    ' Lors d'une destruction par VBA il est souhaitable de désactiver
    ' les "popups"  de validation.
    ' Application.DisplayAlerts = False
    NewSheet.Delete

End Sub
'


Cordialement

Lupin

[VBA] Probleme emplacement macro

3 réponses

Discussions similaires