Macro vereenvoudigen

[stefano]

Ik beschik over een excel blad van waaruit een 50-tal macro's gestuurd worden. Het verschil tussen die macro's bestaat enkel uit de bestandsnaam die verandert. Om niet telkens dezelfde code te moeten herhalen dacht ik een deel van de macro te groeperen in een aparte macro ( zie het rode gedeelte hieronder) en die telkens aan te roepen. Alleen verlies ik blijkbaar de gedefinieerde variabelen wanneer ik terug in mijn oorspronkelijke macro belandt ... Hieronder de codes voor en na. Hoe zou ik dan kunnen opvangen ?

Sub sap_molen_merksem_maand()
    
    Dim Loc1 As String
    Dim Myname1 As String
    Dim Myname2 As String
    Dim Myname3 As String
    Loc1 = "E:\data\sap\"
    Myname1 = "AMSM_1.xls"
    Myname2 = "AMSM_2.xls"
    Myname3 = "Merksem - molen - laatste maand.xls"
    
[COLOR="#FF0000"]    Application.DisplayAlerts = False
    Workbooks.OpenText Filename:=Loc1 & Myname1, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
        Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array( _
        16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1)), TrailingMinusNumbers _
        :=True
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("G:IV").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.000"
    Range("A1").Select
    ActiveWorkbook.SaveAs Filename:=Loc1 & Myname1, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

    Workbooks.Open Filename:=Loc1 & Myname2
    Workbooks(Myname2).Activate
    Cells.Copy
    Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    Workbooks(Myname2).SaveAs Loc1 & Myname3
    Workbooks(Myname1).Close False
    Application.DisplayAlerts = True[/COLOR]    
End Sub

Het rode gedeelte wordt vervangen door de macro application.run "bestandomzetten" waardoor de macro heel wat korter wordt.

Sub sap_molen_merksem_maand()
    
    Dim Loc1 As String
    Dim Myname1 As String
    Dim Myname2 As String
    Dim Myname3 As String
    Loc1 = "E:\data\sap\"
    Myname1 = "AMSM_1.xls"
    Myname2 = "AMSM_2.xls"
    Myname3 = "Merksem - molen - laatste maand.xls"
   
[COLOR="#FF0000"] 
application.run "bestandomzetten"   [/COLOR]
 
End Sub

Sub bestandomzetten()
    
    Application.DisplayAlerts = False
    Workbooks.OpenText Filename:=Loc1 & Myname1, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
        Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array( _
        16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1)), TrailingMinusNumbers _
        :=True
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("G:IV").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.000"
    Range("A1").Select
    ActiveWorkbook.SaveAs Filename:=Loc1 & Myname1, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

    Workbooks.Open Filename:=Loc1 & Myname2
    Workbooks(Myname2).Activate
    Cells.Copy
    Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    Workbooks(Myname2).SaveAs Loc1 & Myname3
    Workbooks(Myname1).Close False
    Application.DisplayAlerts = True[/COLOR]    
End Sub

 

[HSV]

Als alle bestanden in dezelfde map staan, en je bestand met de macro ergens anders.
Doe het in een testbestand met testbestandjes in een aparte map.
Nu komt in elk bestand in de aparte map in blad1 cel a1 "werkt mooi" te staan.

Sub WrkBksopen()
Dim bestandopen as string
 bestandopen = Dir("C:\Map1\Map2\*")
    Do Until bestandopen = ""
      If bestandopen = "" Then Exit Do
        Workbooks.Open "C:\Map1\Map2\" & bestandopen
        ActiveWorkbook.Sheets("Blad1").Range("a1") = "werkt mooi"
        Application.DisplayAlerts = False
        Workbooks(bestandopen).Close True
      bestandopen = Dir
    Loop
 Application.DisplayAlerts = True
End Sub

 

[Warme bakkertje]

Misschien op deze manier.

Sub sap_molen_merksem_maand()
    
    Dim Loc1 As String, Myname1 As String, Myname2 As String, Myname3 As String
    Loc1 = "E:\data\sap\"
    Myname1 = "AMSM_1.xls"
    Myname2 = "AMSM_2.xls"
    Myname3 = "Merksem - molen - laatste maand.xls"
   
    Call bestandomzetten(Loc1, Myname1, Myname2, Myname3)
 
End Sub

Sub bestandomzetten(fLoc As String, fName1 As String, fName2 As String, fName3 As String)
    
    Application.DisplayAlerts = False
    Workbooks.OpenText Filename:=fLoc & fName1, Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _
        Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array( _
        16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1)), TrailingMinusNumbers _
        :=True
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("G:IV").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.000"
    Range("A1").Select
    ActiveWorkbook.SaveAs Filename:=fLoc & fName1, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

    Workbooks.Open Filename:=fLoc & fName2
    Workbooks(fName2).Activate
    Cells.Copy
    Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    Workbooks(fName2).SaveAs fLoc & fName3
    Workbooks(fName1).Close False
    Application.DisplayAlerts = True
End Sub