Simplification code macro

Le 14/03/2013 à 00:18

Bonsoir,

Débutant sur Excel et surtout en VB, je souhaiterai votre aide.

J' ai "créer" ( en voilà un bien grand mot ) une macro à 80% par le biais de l' enregistreur automatique de macro, 10% de commandes trouvé sur les forums et 10% de bien veillance d' Eric.

Pouvez-vous jeter un coup d'oeil sur cette dite macro et me dire comment l' alléger ( car elle est pas encore fini, environ 80% ) et je trouve qu' elle ressemble plus à une encyclopédie qu' une macro au vue du nombre de lignes.

Merci de votre aide.

Sub A_RAP_2013()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

repracine = ActiveWorkbook.Path & "\"

Workbooks.OpenText Filename:=repracine & "rappro.txt", _
        Origin:=65001, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
        Array(0, 1), Array(13, 1), Array(44, 1), Array(58, 1), Array(74, 1), Array(86, 1), Array( _
        117, 1), Array(133, 1), Array(147, 1), Array(157, 1), Array(173, 1)), _
        TrailingMinusNumbers:=True
    Cells.Select
    Cells.EntireColumn.AutoFit

copierRap

    Range("A1:C30").ClearContents

'Etat de Rapprochement
    Range("A26").ClearContents
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[4],RC[5])"
'Arrêté au :...
    Range("A27").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[4],"" "",RC[5])"
'Compte social..
    Range("A28").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[3],RC[4],RC[5])"
'Compte Bq
    Range("A29").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[3],RC[4],RC[5])"
'Identifiant
    Range("A23").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[3]C[6],R[3]C[7],R[3]C[8],R[3]C[9],R[3]C[10])"
'Cop/col en valeur
    Range("A6:A30").Copy
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'Effacer les autres lignes
    Range("B1:K30").ClearContents
'Suppr les autres lignes
    Range("A1:K21").EntireRow.Delete

'Centrer + fusion+ gras de l entête
    Range("A2:K2").Select
    With Selection
        .HorizontalAlignment = xlCenter 'centrer-celui du bas
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge ' fusionner
     With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter ' center-celui du haut
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Font.Bold = True 'mettre en gars
Range("A5:K5").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Font.Bold = True
Range("A6:K6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Font.Bold = True
Range("A7:K7").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Font.Bold = True
Range("A8:K8").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.Font.Bold = True

' Complete "Solde compta" et efface le "S" en A17
    Range("B17").Select
    ActiveCell.FormulaR1C1 = "Solde comptabilité"
    Range("A17").ClearContents

' Selectionne C17 à D500 pour suppr la virgule et le mettre en format chiffre
    Range("C17:D500").Select
    Selection.Style = "Comma"
    Selection.Replace What:=",", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

    Range("G17:H500").Select
    Selection.Style = "Comma"
    Selection.Replace What:=",", Replacement:="", lookat:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

' Mise en forme du reste de la page
    Range("A17:A500").Select
    Selection.NumberFormat = "mm-dd-yyyy;@"
    Range("E17:E500").Select
    Selection.NumberFormat = "mm-dd-yyyy;@"

    Range("A16:K500").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("I16:I500").Select
    Selection.NumberFormat = "General"
    Range("K16:K500").Select
    Selection.NumberFormat = "General"
    Range("B16:B500").Select
    Selection.NumberFormat = "# ??/??"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("F16:F500").Select
    Selection.NumberFormat = "# ??/??"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 2) Like "olde comptabilité" Then Cells(i, 2) = "Solde comptabilité"
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 2) Like "Solde comptabilité" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "Tot" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "===" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "---" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 1).Cells.ClearContents
Next i

'Mise sur 1 page+réduction des marges
    With ActiveSheet.PageSetup

        .Orientation = xlLandscape
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.236220472440945)
        .BottomMargin = Application.InchesToPoints(0.236220472440945)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)

        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True

        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True

End With

miseEnPage

Application.ScreenUpdating = True
End Sub

Sub auto_open() 
    MenuBars(xlWorksheet).Menus.Add Caption:="&Rapprochement Bancaire", Before:=12
    With MenuBars(xlWorksheet).Menus("Rapprochement Bancaire").MenuItems
        .Add Caption:="&Rappro", OnAction:="Rappro"
    End With
    MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"
End Sub

Sub auto_close()
     For Each m In MenuBars(xlWorksheet).Menus
        If m.Caption = "&Rapprochement Bancaire" Then m.Delete
     Next

     For Each o In MenuBars(xlWorksheet).Menus
     If o.Caption = "&Rappro" Then o.Delete
     Next

For Each N In MenuBars(xlWorksheet).Menus("Outils").MenuItems
If N.Caption = "&Rapprochement Bancaire" Then N.Delete
Next

For Each p In MenuBars(xlWorksheet).Menus("Outils").MenuItems
If p.Caption = "&Rappro" Then p.Delete
Next
End Sub
Sub copierRap()
    Dim derlig As Long, lig1 As Long, lig2 As Long, nomF As String
    Dim i As Long, nbRap As Long
    Dim adr1 As String, c As Range
    Set c = Cells.Find("Etat de rap", LookIn:=xlValues, lookat:=xlWhole)
    derlig = Cells.SpecialCells(xlCellTypeLastCell).Row
    If Not c Is Nothing Then
        adr1 = c.Address
        lig1 = c.Row
        Do
            Set c = Cells.FindNext(c)
            If c.Address = adr1 Then
                lig2 = derlig
            Else
                lig2 = c.Row - 1
            End If
            i = i + 1
            nomF = "Etat de rap " & i
            créerFeuille nomF, True, False
            Range(Rows(lig1), Rows(lig2)).Copy Worksheets(nomF).[a1]
            lig1 = lig2 + 1
        Loop While Not c Is Nothing And c.Address <> adr1
    End If
End Sub

Function créerFeuille(nomFeuille As String, Optional ecraser As Boolean = False, Optional alerte As Boolean = True)
'crée une feuille en supprimant l'existant si besoin
    Dim ActSh As Worksheet, existeFeuille As Boolean
    Dim alertState As Boolean, screenUpdatingState As Boolean
    ' sauver environnement
    Set ActSh = ActiveSheet
    alertState = Application.DisplayAlerts
    screenUpdatingState = Application.ScreenUpdating
    Application.ScreenUpdating = False
    If Not alerte Then Application.DisplayAlerts = False
    '
    On Error Resume Next
    existeFeuille = Sheets(nomFeuille).Index
    On Error GoTo 0
    If existeFeuille And ecraser Then Worksheets(nomFeuille).Delete: existeFeuille = 0
    If Not existeFeuille Then
        'créer feuille
        Worksheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = nomFeuille
    End If
    ' restaurer environnement
    ActSh.Activate
    Application.DisplayAlerts = alertState
    Application.ScreenUpdating = screenUpdatingState
End Function

Sub miseEnPage()
Application.ScreenUpdating = False
    Dim sh As Worksheet
    For Each sh In Worksheets
    sh.Select
    If Left(sh.Name, 11) = "Etat de rap" Then

Range("A1:C6").Select
    Selection.ClearContents
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[4],RC[5])"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[4],"" "",RC[5])"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[3],RC[4],RC[5])"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[3],RC[4],RC[5])"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = _
        "=CONCATENATE(R[-5]C[6],R[-5]C[7],"" "",R[-5]C[8],R[-5]C[9],R[-5]C[10])"
    Range("A1:A6").Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("C1:K4").Select
    Selection.ClearContents
    Range("A1:K1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    Range("A1:K1").Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A8:K8").Cut
    Range("A1").Select
    ActiveSheet.Paste

    Cells.Select
    Cells.EntireColumn.AutoFit

' Complete "Solde compta" et efface le "S" en A15
    Range("B15").Select
    ActiveCell.FormulaR1C1 = "Solde comptabilité"
    Range("A15").ClearContents

' Selectionne C15 à D500 pour suppr la virgule et le mettre en format chiffre
    Range("C15:D500").Select
    Selection.Style = "Comma"
    Selection.Replace What:=",", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

    Range("G15:H500").Select
    Selection.Style = "Comma"
    Selection.Replace What:=",", Replacement:="", lookat:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

' Mise en forme du reste de la page
    Range("A15:A500").Select
    Selection.NumberFormat = "mm-dd-yyyy;@"
    Range("E15:E500").Select
    Selection.NumberFormat = "mm-dd-yyyy;@"

    Range("A16:K500").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("I16:I500").Select
    Selection.NumberFormat = "General"
    Range("K16:K500").Select
    Selection.NumberFormat = "General"
    Range("B16:B500").Select
    Selection.NumberFormat = "# ??/??"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("F16:F500").Select
    Selection.NumberFormat = "# ??/??"
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

'Mise sur 1 page+réduction des marges
    With ActiveSheet.PageSetup

        .Orientation = xlLandscape
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.236220472440945)
        .BottomMargin = Application.InchesToPoints(0.236220472440945)
        .HeaderMargin = Application.InchesToPoints(0.196850393700787)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)

        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True

        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True

End With

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 2) Like "olde comptabilité" Then Cells(i, 2) = "Solde comptabilité"
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 2) Like "Solde comptabilité" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "Tot" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "Tot" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "===" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "===" Then Cells(i, 1).Cells.ClearContents
Next i

For i = [A65000].End(xlUp).Row To 1 Step -1
If Cells(i, 1) Like "---" Then Cells(i, 6).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 5).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 2).Cells.ClearContents
If Cells(i, 1) Like "---" Then Cells(i, 1).Cells.ClearContents
Next i

End If
Next sh
End Sub
Le 14/03/2013 à 08:58

Bonjour,

En voyant ton code, voici déjà deux modifications que je ferais concernant l'ouverture du fichier et sa fermeture.

Dans le module où se trouve les deux codes Sub Auto_open et Auto_close, remplace les par ceci :

Sub Menu()
Call supprimemenu
MenuBars(xlWorksheet).Menus.Add Caption:="&Rapprochement Bancaire", Before:=12
With MenuBars(xlWorksheet).Menus("Rapprochement Bancaire").MenuItems
    .Add Caption:="&Rappro", OnAction:="Rappro"
End With
MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"
End Sub
Sub supprimemenu()
Dim m, o, N, P
On Error Resume Next
For Each m In MenuBars(xlWorksheet).Menus
    If m.Caption = "&Rapprochement Bancaire" Then m.Delete
Next

For Each o In MenuBars(xlWorksheet).Menus
    If o.Caption = "&Rappro" Then o.Delete
Next

For Each N In MenuBars(xlWorksheet).Menus("Outils").MenuItems
    If N.Caption = "&Rapprochement Bancaire" Then N.Delete
Next

For Each P In MenuBars(xlWorksheet).Menus("Outils").MenuItems
    If P.Caption = "&Rappro" Then P.Delete
Next
End Sub

Va ensuite dans VBA, et double clique sur THISWORBOOK

Dans la fenêtre place ces deux codes :

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call supprimemenu
End Sub

Private Sub Workbook_Open()
Call Menu
End Sub

Amicalement

Le 14/03/2013 à 10:34

Bonjour Dan,

Merci pour ta réponse aussi rapide.

J' ai suivi tes conseils et remplacé Sub Auto_open et close par tes commandes de même que j' ai placé les 2 codes dans Workbook.

Le problème est que lorsque j' ouvre ma macro, il m' affiche l' erreur suivante :

" Erreur d' exécution '1004':

Erreur définie par l' application ou par l' objet. "

Et lorsque je clique sur Débogage, j' obtiens cette ligne surligné en jaune avec la fléche jaune :

MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"

Merci de ton aide.

Le 14/03/2013 à 12:43

Re,

Vérifie bien que les macros open et before close sont bien celles que je t'ai données dan mon fil car j'ai modifié un truc dans les minutes qui ont suivi mon post.

Une chose que je ne comprends pas est pourquoi tu veux avoir l'option RAPPRO à la fois dans le menu OUTILS et dans le menu RAPPROCHEMENT que tu crées. Il y a une raison ??

A te relire

Le 14/03/2013 à 14:05

Re,

Je te confirmes bien, avoir supprimé les 2 macros Auto open et Auto close que j' avais pour les remplacer par les tiennes.

J' ai également collé les commandes dans le Workbook. Malgré celà il m' affiche le message d' erreur et la surligne dans le Débogeur :

MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"

Dan a écrit :

Une chose que je ne comprends pas est pourquoi tu veux avoir l'option RAPPRO à la fois dans le menu OUTILS et dans le menu RAPPROCHEMENT que tu crées. Il y a une raison ??

En fait je souhaiterai avoir, au dessus du Ruban une commande " Complément " et le raccourci pour lancer la macro de manière à ce qu'une personne qui n'y connais rien sur Excel puisse lancer la macro et exploiter le fichier ( voir le Printscreen sur l' onglet 1 du fichier joint).

Pour t' expliquer j'ai un fichier en format Txt qui a plusieurs Rapprochement bancaire l' un en dessous de l' autre ( par ex : 20 ). Ces 20 rappros concerne 20 personnes différentes. Je voudrai qu' il copie chaque rappro sur un onglets différent et fasse la mise en page de manière à ce que je puisse imprimer le rappro et l' envoyer aux personnes concernés.

N'hésites pas à me dire si je ne suis pas trés clair.

Merci

39rappro.zip (44.76 Ko)
Le 15/03/2013 à 08:11

re,

Comme tu utilisais les Sub open et Sub close, j'ai pensé que tu étais sous une version d'excel 2003 ou inférieur

Je vois ce que tu veux et vais regarder pour modifier le code.

Il est normal que tu plantes à ce niveau puisque le menu "Outils" nexiste pas.

Sous excel 2007, pour faire appraitre l'onglet "complément", il faut que tu ailles activer l'option par Fichier -> Option -> Personnaliser le ruban.

Amicalement

Edit Dan :enlève cette ligne de ton code --> MenuBars(xlWorksheet).Menus("Outils").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"

Le 15/03/2013 à 13:34

Re,

En supplément à mon post précédent, modifie les deux codes menu et supprimemenu comme suit :

Sub Menu()
Call supprimemenu
With MenuBars(xlWorksheet)
    .Menus.Add Caption:="&Rapprochement Bancaire"
    .Menus("Rapprochement Bancaire").MenuItems.Add Caption:="&Rappro", OnAction:="Rappro"
End With
End Sub 

Sub supprimemenu()
Dim m ', o, N, P
On Error Resume Next
For Each m In MenuBars(xlWorksheet).Menus
    If m.Caption = "&Rapprochement Bancaire" Then m.Delete
Next
End Sub

Cela te donnera un menu déroulant avec la macro RAPPRO

A te relire

Le 19/03/2013 à 23:46

Bonsoir Dan,

Merci de ton aide, j' ai plus de messages d'erreur.

N'hésites pas revenir vers moi si tu as des suggestions de simplification et d' amélioration de ma macro

Le 22/03/2013 à 13:21

Re,

suggestions de simplification et d' amélioration de ma macro

Ok je vais essayer de te proposer quelque chose car sans fichier c'est moins facile

Amicalement

Le 23/03/2013 à 21:06

Bonsoir Dan,

Voici un fichier Txt, simplifié, que j' utilise pour lancer la macro.

Petite modification à apporter :

Je dois modifier la macro sur la commande de copie d' un rapprochement bancaire par onglet. CAD, il doit copier un rappro par onglet chaque fois qu' il voit la mention " Etat de rapprochement " et surtout à chaque changement de code " [b]01000 : BB[/b]" qui se trouve en haut à droite du fichier (

J Etat de rapprochement bancaire 01000 : BB

)

Dit moi si je ne suis pas claire.

@+

36rappro-ibz.txt (17.46 Ko)
Rechercher des sujets similaires à "simplification code macro"