Macro d'un fichier à l'autre

[ritournelle]

Bonjour,

Votre aide me serait d'un grand secours, je suis novice en matière de macros...

J'ai à présent et après force lutte un fichier doté d'une macro qui fonctionne comme je le souhaite :

Sub ExtraireVersAutreFeuille()
critere = InputBox("Critere?")
  If critere = "" Then Exit Sub
  [Feuil1!A2].AutoFilter Field:=1, Criteria1:="*" & critere & "*"
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets(critere).Delete
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = critere
  Sheets("Feuil1").Range("_FilterDataBase").SpecialCells(xlCellTypeVisible).Copy [A1]
  Cells.EntireColumn.AutoFit
  Sheets("Feuil1").ShowAllData
Rows("1:1").Select
    Selection.RowHeight = 38.25
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Rows("3:3").Select
    Selection.RowHeight = 12.75
    Rows("1:1").Select
    Selection.RowHeight = 16.5
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "OCTOBRE 2008"
    Range("I1").Select
    Selection.Font.ColorIndex = 3
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Columns("A:A").Select
    Selection.ColumnWidth = 4.86
    Columns("B:B").Select
    Selection.ColumnWidth = 3.71
    Columns("C:C").Select
    Selection.ColumnWidth = 9
    Columns("D: D").Select
    Selection.ColumnWidth = 15
    Columns("E:E").Select
    Selection.ColumnWidth = 10
    Columns("F:F").Select
    Selection.ColumnWidth = 9
    Columns("G:G").Select
    Selection.ColumnWidth = 7
    Columns("H:H").Select
    Selection.ColumnWidth = 10
    Columns("I:I").Select
    Selection.ColumnWidth = 53.57
    Columns("J:N").Select
    Selection.ColumnWidth = 9
    ActiveWindow.ScrollColumn = 3
    Columns("O:O").Select
    Selection.ColumnWidth = 8.86
    ActiveWindow.Zoom = 90
    ActiveWindow.ScrollColumn = 1
    Range("B3").Select
    Selection.Interior.ColorIndex = xlNone
    Range("I1").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
    End With
    Range("A1:O1").Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = True
    End With
    
    Range("B4:B50").Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=-6
    Selection.NumberFormat = "General"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",1)"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""","""",R[-1]C+1)"
    Range("B5").Select
    Selection.AutoFill Destination:=Range("B5:B6"), Type:=xlFillDefault
    Range("B5:B6").Select
    Range("B6").Select
    Selection.AutoFill Destination:=Range("B6:B47"), Type:=xlFillDefault
    Range("B6:B50").Select
    Range("A6").Select
    
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "LS SA"
        .CenterFooter = "&F"
        .RightFooter = "&D"
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.78740157480315)
        .BottomMargin = Application.InchesToPoints(0.78740157480315)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 78
    End With
End Sub

Je l'ai enregistrée dans mon fichier de test et si je la copie et la colle dans une autre macro dans un autre fichier, elle ne fonctionne plus... Si je renomme le fichier elle ne fonctionne plus non plus ! Comment pratiquer pour que je puisse l'utiliser dans un autre fichier qui en plus est destiné à être copié et renommé mensuellement, et que ma macro suive et fonctionne ???

Comment faire pour que le mois "OCTOBRE 2008" qui apparaît sur les nouvelles feuilles créées puisse se mettre automatiquement à jour en fonction de l'indication d'une cellule qui se trouve sur la feuil1 ?

Un grand merci par avance pour votre aide

 

[Staple1600]

Re : Macro d'un fichier à l'autre

Bonjour




Je m'en doutais, c'est pour cela que je te demandais de poster un fichier exemple (avec le résultat obtenu avec ta macro)

 

[ritournelle]

Re : Macro d'un fichier à l'autre

Je vais l'anonymiser et je le mets sous peu.

Grrrrr, j'arrive pas, mon fichier est trop lourd....
Je tente de l'amaigrir mais ça ne suffit toujours pas...

 

[ritournelle]

Re : Macro d'un fichier à l'autre

Le voici enfin

 

[Staple1600]

Re : Macro d'un fichier à l'autre

Re



Voici une méthode d'amaigrissement

1) Ouvrir un classeur vierge

2) Ouvrir ton classeur

Faire Fenêtre/Réorganiser/Horizontal

Tu as maintenant à l'écran deux fenêtres

Tu cliques sur l'onglet (utile: feuil1) et tu le déplaces

vers le classeur vierge.

Ensuite tu ouvres VBE (ALT+F11) et là aussi tu déplaces le module
vers le classeur vierge.

Tu fermes ton classeur d'origine (sans enregistrer les modifications)

Puis tu supprimes un maximun de lignes (20 lignes restantes suffiront)
(Tu supprimes les images, les couleurs)

Enfin tu fermes le classeur vierge et tu le zippes.

Théoriquement la taille devrait avoir considérablement diminiuée.

 

[ritournelle]

Re : Macro d'un fichier à l'autre

Je l'ai posté juste au-dessus, si ça ne joue pas, je prendrai ta méthode ! Merci again pour ton aide !

 

[Staple1600]

Re : Macro d'un fichier à l'autre

Re




Je te laisse tester


Normalement le résultat est le même qu'avec ta macro originale.

 

[ritournelle]

Re : Macro d'un fichier à l'autre

Oui, à part le zoom à 90%, c'est très exactement ça !

Vraiment merci pour tout le temps que tu as consacré à mon fichier !

Je vais maintenant passer à la suite, imbriquer une fonction SI et une RECHERCHEV dans le script VB, pour envoyer les feuilles ainsi nouvellement créées, soit par fax soit par email, en fonction que l'un ou l'autre est existant dans un tableau de données correspondant au critère initial... mais c'est complexe, je vais créer un nouveau post.

Avec encore tous mes remerciements renouvelés pour l'aide apportée