Macro d'un fichier à l'autre

ritournelle · 10 Octobre 2008

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 :

Code:

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

Compte Supprimé 979 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Bonjour Ritournelle et bienvenue sur ce forum

D'après ce que je vois dans ton code, au départ de la macro, tu fais appelle à une plage nommée : _FilterDataBase

Code:

...
Sheets("Feuil1").Range("[B][COLOR=red]_FilterDataBase[/COLOR][/B]").SpecialC ells(xlCellTypeVisible).Copy [A1]
...

Donc si cette plage n'existe pas dans ton nouveau classeur, forcément ça bug

A+

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Merci pour ta réponse Bruno !

La plage existe dans les autres fichiers aussi, il s'agit du filtre automatique dans un tableau existant.

Entre-temps j'ai réussi à résoudre la 1ère partie du pb, à vrai dire. Il faut que les deux classeurs soient ouverts en même temps pour pouvoir recopier la macro dans le second fichier. Puis casser le lien entre les deux fichiers pour échapper à la fenêtre sur la mise à jour des liaisons !

Reste la seconde question, celle de la mise à jour du mois dans Feuil1 qui se répercuterait dans les nouvelles feuilles créées par la macro après le filtre automatique.

Compte Supprimé 979 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Re,

Entre-temps j'ai réussi à résoudre la 1ère partie du pb, à vrai dire. Il faut que les deux classeurs soient ouverts en même temps pour pouvoir recopier la macro dans le second fichier. Puis casser le lien entre les deux fichiers pour échapper à la fenêtre sur la mise à jour des liaisons !

Alors là, il y a un soucis !?
Je ne vois pas pourquoi tu aurais besoin d'ouvrir les 2 fichiers en même temps pour copier une macro !
Une copie ce fait via le "presse papier" de windows,
mais bon !

Pour la seconde question, il suffit de faire

Code:

ActiveSheet.Range("I1").Value = Sheets("Feuil1").range("[B][COLOR=blue]A1[/COLOR][/B]").value

Si la valeur à récupérer de la feuille1 se trouve dans la cellule A1

Voili, voilà

A+

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Je ne sais sans doute pas m'y prendre, mais jusque là un copier tel quel et la macro ne fonctionnait pas, peut-être encore une histoire de liaison, il semblait chercher l'autre fichier...

Merci beaucoup pour la ligne de script, je n'arrivais pas à la générer, ne connaissant pas la syntaxe, pour le reste je me suis débrouillée en enregistrant les macros et en recopiant les "bouts" dans la macro principale... mais là impossible !

Encore un tout grand merci pour ton aide

Staple1600 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Bonsoir à tous

Je me suis permis de faire maigrir ta macro

( afin d'éviter les Select )

Code:

Sub ExtraireVersAutreFeuille_II()
Dim i As Long
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").RowHeight = 16.5
Rows("2:2").RowHeight = 38.25
Rows("3:3").RowHeight = 12.75
With Range("I1")
.FormulaR1C1 = "OCTOBRE 2008"
    With .Font
        .Size = 12
        .ColorIndex = 3
        .Bold = True
    End With
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
End With
LCol = Split("4.86/3.71/9/15/10/9/7/10/53.57", "/")
For i = 0 To UBound(LCol)
Columns(i + 1).ColumnWidth = LCol(i)
Next
Columns("J:N").ColumnWidth = 9
Columns("O:O").ColumnWidth = 8.86
Range("B3").Interior.ColorIndex = xlNone
With Range("A1:O1")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .MergeCells = True
End With
Range("B4:B50").ClearContents
Range("B4").FormulaR1C1 = "=IF(RC[-1]="""","""",1)"
Range("B5").FormulaR1C1 = "=IF(RC[-1]="""","""",R[-1]C+1)"
Range("B5").AutoFill Destination:=Range("B5:B6"), Type:=xlFillDefault
Range("B6").AutoFill Destination:=Range("B6:B47"), Type:=xlFillDefault
End Sub

Peux-tu tester pour voir si le résultat est le même

(Ou poster un exemple de ton fichier (anonymisé) que je fasse le test)

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Je ne suis guère étonnée qu'une cure d'amaigrissement lui soit envisageable, voire bénéfique

Merci de m'avoir répondu Staple1600.

Le fichier est au travail, je regarde ça demain après-midi et te redis.

Bien cordialement.

Staple1600 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Re

PS: j'ai supprimé le code (juste pour tester) de mise en page avant impression.

Il suffira de copier coller la dernière partie de ton code pour avoir la amcro complète.

Partie à recopier dans ton code
(voir ton message contenant la macro complète

Code:

     ActiveSheet.PageSetup.PrintArea = ""
...
...
End Sub

PS: Tu peux éditer ton message en utilisabt la balise CODE
Voir ici Balises BB comment faire

Cela rendre rend le code VBA plus lisible.

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Voilà c'est fait pour la balise !

J'avais vu qu'il manquait la partie préparation à l'impression. Merci pour tout ! Je regarde demain.

Ah oui, encore une question qui me vient, si le script de la macro est plus bref, cela a une incidence sur le temps d'exécution ?

Staple1600 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Re

En principe il est conseillé d'éviter de recourir au Select et Selection car cela ralentit l'éxécution de la macro.

Donc oui en évitant au maximum ces sélections , le code s'éxécutera plus rapidement.

De même, en ajoutant
Application.ScreenUpdating.False
'au début du code

'et à la fin du code
Application.ScreenUpdating=True

On accélère l'exécution.

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

Eh bien, j'en apprends des choses, merci pour toutes ces infos ! Je vais sérieusement revoir ma copie, moi qui étais toute contente d'avoir enfin un résultat probant après avoir "transpiré" toutes ces heures (si, si!) sur cette malheureuse macro

Staple1600 · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

RE

Tu peux être fière d'avoir suer pour VBA et Excel

ritournelle · 10 Octobre 2008

Re : Macro d'un fichier à l'autre

cela n'aura pas été en vain !

ritournelle · 11 Octobre 2008

Re : Macro d'un fichier à l'autre

Bonjour Staple1600,

Alors je viens de tester, le résultat n'est pas du tout à l'identique, essentiellement au niveau de la mise en forme. La nouvelle feuille est bien générée, le contenu des données est ok, mais la mise en forme ne l'est pas elle

Merci quand même pour ton aide.
Bien cordialement.

ritournelle · 11 Octobre 2008

Re : Macro d'un fichier à l'autre

BrunoM45 à dit:
Pour la seconde question, il suffit de faire

Code:

ActiveSheet.Range("I1").Value = Sheets("Feuil1").range("[B][COLOR=blue]A1[/COLOR][/B]").value

Nickel, ça ça fonctionne à merveille ! Merci beaucoup !

Sinon, le truc que je comprends c'est pourquoi il faut qu'en lançant ma macro il m'ouvre mon fichier de travail test dans la foulée... j'ai pourtant cassé la liaison... voilà mon prochain défi !

Effectuez une recherche sur Excel Downloads...

Macro d'un fichier à l'autre

ritournelle

XLDnaute Nouveau

Compte Supprimé 979

Guest

ritournelle

XLDnaute Nouveau

Compte Supprimé 979

Guest

ritournelle

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

ritournelle

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

ritournelle

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

ritournelle

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

ritournelle

XLDnaute Nouveau

ritournelle

XLDnaute Nouveau

ritournelle

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums