VBA-Code ändern

[heli]

Liebes Forum !

Ich möchte Euch gerne wieder einmal um Eure geschätzte Hilfe bitten, zumal ich mit meinem geringen Latein am Ende bin.
Ich habe einen Code zum Ändern eines Codes gefunden, der auch wie gewünscht alle Tabellenblätter durchläuft und die Änderung vornimmt, bis dann plötzlich als "objCodeModule"   "DieseArbeitsmappe"  erscheint und dann führt es zu einem gravierenden Excel-Fehler und Excel wird neu gestartet.
Ich dachte ich könnte mit einer Abfrage und überspringen zum Ende eine Lösung finden, aber leider nicht.
Ich vermute es hat was mit Select Case zu tun, aber ich kann auch mit Case=100 auch nichts anfangen.
Kann mir bitte jemand sagen, woran es liegt.
Vielen Dank.
Liebe Grüße aus Innsbruck
Helmut

Code:

Sub Ändern_CB10_Code()         ' Die Sub des CB10 in allen TBs ändern
   
   Dim wb As Workbook
   Set wb = ActiveWorkbook
 
  prcStart wb
End Sub

Public Sub prcStart(wb As Workbook)
  Dim objVBComponents As Object, i As Integer, j As Integer
  With wb.VBProject    'alle Tabellen werden aufgerufen
     For Each objVBComponents In .VBComponents
        Select Case objVBComponents.Type
        Case 1   '2, 3        'Module, Klasssenmodule, Userforms
           '.VBComponents.Remove .VBComponents(objVBComponents.Name)  'wird für Module etc. verwendet
        Case 100       'Workbook, Sheets, Carts
           i = 0: j = 0
           Call prcFindProc("CommandButton10_Click", objVBComponents.CodeModule, i, j)  'Zu änderndes Modul
           'i = ab CommandButton10_Click
                                                               
           If i > 0 And j > 0 Then
              Call prcDelete(objVBComponents.CodeModule, i, j) 'Löschen aller Zeilen des Moduls
              Call InsertProc(objVBComponents.CodeModule, i)
           End If
        End Select
     Next
  End With
End Sub

Public Sub prcFindProc(strProc As String, objCodeModule As Object, intStartLine As Integer, intEndLine As Integer)
  Dim intLine As Integer, sLine As String
  With objCodeModule   'alle Tabellen werden aufgerufen
     
     'If objCodeModule = "DieseArbeitsmappe" Then
'GoTo Ende
     'End If
     
     For intLine = 1 To .CountOfLines
        If .ProcOfLine(intLine, 0) = strProc Then
           sLine = Trim(.Lines(intLine, 1))
           If intStartLine = 0 And InStr(1, sLine, strProc) > 0 And Left(sLine, 1) <> "'" Then
              intStartLine = intLine + 1
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") = 0 Then
              intEndLine = intLine
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") > 0 Then
              Exit For
           End If
        End If
     Next
     intEndLine = intEndLine - intStartLine + 1
  End With

[Steffl]

Hallo Helmut,

was welche Änderungen und wo willst Du vornehmen? Doch sicherlich nicht in allen (Klassen-)Modulen und in allen Prozeduren. Dein Codebeispiel ist übrigens unvollständig.

[schauan]

Hallöchen,

hier mal eine Nummernübersicht:
' Modul: Typ 1
' Klasse: Typ 2
' Userform: Typ 3
' Tabelle: Typ 100
' DieseArbeitsmappe: Typ 100

Das hier
If objCodeModule = "DieseArbeitsmappe" Then
ging wohl nicht, weil "DieseArbeitsmappe" der Name ist, also besser
If objCodeModule.name = "DieseArbeitsmappe" Then

Bei Änderungen in DieseArbeitsmappe habe ich auch die Erfahrung gemacht, dass dadurch zuweilen Excel abstürzt. Eventuell hilft, die Datei mit deaktivierten Makros zu öffnen und dann zu ändern.

[heli]

Hallo liebe Helfer !

Vielen Dank für Eure Antwort.
Ich habe offensichtlich unbeabsichtigt nicht den ganzen Code kopiert, wofür ich mich entschuldige und darf das nun nachholen.

Es soll der Code nur für "CommandButton10"  in allen 12 Tabellenblätter (Jänner bis Dezember) geändert werden, was ja auch funktioniert, aber nach TB 12 wird "DieseArbeitsmappe" aufgerufen, was in der Folge zu einem Fehler führt und ich muss dann manuell eingreifen, d.h. speichern, das aber für eine Reihe von Dateien, die alle geändert werden müssen.

Den Hinweis "If objCodeModule.name = "DieseArbeitsmappe" Then" zu ändern, werde ich gleich testen. Vielen Dank auch für die Zahlenwerte, wo kann man diese nachlesen ?


Vielen Dank für Eure Hilfe.
Liebe Grüße
Helmut

 

Code:

Sub Ändern_CB10_Code()         ' Die Sub des CB10 in allen TBs ändern
   
   Dim wb As Workbook
   Set wb = ActiveWorkbook
 
  prcStart wb
End Sub

Public Sub prcStart(wb As Workbook)
  Dim objVBComponents As Object, i As Integer, j As Integer
  With wb.VBProject    'alle Tabellen werden aufgerufen
     For Each objVBComponents In .VBComponents
        Select Case objVBComponents.Type
        Case 1   '2, 3        'Module, Klasssenmodule, Userforms
           '.VBComponents.Remove .VBComponents(objVBComponents.Name)  'wird für Module etc. verwendet
        Case 100       'Workbook, Sheets, Carts
           i = 0: j = 0
           Call prcFindProc("CommandButton10_Click", objVBComponents.CodeModule, i, j)  'Zu änderndes Modul
           'i = ab CommandButton10_Click
                                                               
           If i > 0 And j > 0 Then
              Call prcDelete(objVBComponents.CodeModule, i, j) 'Löschen aller Zeilen des Moduls
              Call InsertProc(objVBComponents.CodeModule, i)
           End If
        End Select
     Next
  End With
End Sub

Public Sub prcFindProc(strProc As String, objCodeModule As Object, intStartLine As Integer, intEndLine As Integer)
  Dim intLine As Integer, sLine As String
  With objCodeModule   'alle Tabellen werden aufgerufen
     
     'If objCodeModule = "DieseArbeitsmappe" Then
'GoTo Ende
     'End If
     
     For intLine = 1 To .CountOfLines
        If .ProcOfLine(intLine, 0) = strProc Then
           sLine = Trim(.Lines(intLine, 1))
           If intStartLine = 0 And InStr(1, sLine, strProc) > 0 And Left(sLine, 1) <> "'" Then
              intStartLine = intLine + 1
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") = 0 Then
              intEndLine = intLine
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") > 0 Then
              Exit For
           End If
        End If
     Next
     intEndLine = intEndLine - intStartLine + 1
  End With


Ende:
End Sub

Public Sub prcDelete(objCodeModule As Object, intStartLine As Integer, intEndLine As Integer)
  objCodeModule.DeleteLines intStartLine, intEndLine       'Löschen des Inhaltes bis End Sub
End Sub
Sub InsertProc(objCodeModule As Object, i As Integer)       'Einfügen des neuen Codes
  With objCodeModule
    .InsertLines i + 0, "   Application.ScreenUpdating = False"
    .InsertLines i + 1, "   Dim tb"
    .InsertLines i + 2, "   tb = ActiveSheet.Name"
    .InsertLines i + 3, "   Änderung_Speich_1TB         'Modul"
    .InsertLines i + 4, "   Sheets(tb).Select"
    .InsertLines i + 5, "   druck=True"
    .InsertLines i + 6, "   ActiveSheet.PrintOut"
    .InsertLines i + 7, "   Application.ScreenUpdating = True"
  End With
End Sub

[schauan]

Hallo Helmut,

die Nummern stehen bestimmt irgendwo bei Microsoft. Über einen Umweg bekommt man aber auch selber was raus. Füge ein Modul, ein Klassenmodul und ein Userform ein, lasse diesen code laufen und schaue ins Direktfenster

Code:

Sub test()
With ThisWorkbook.VBProject
    For Each vbc In .VBComponents
    Debug.Print vbc.Name & vbTab & vbc.Type
    Next
End With
End Sub

[heli]

Hallo Andrè !

Ich habe die Abfrage "If objVBComponents.CodeModule.Name = "DieseArbeitsmappe" Then" nun unter "Sub prcStart(wb As Workbook)" gestellt und dann ging es.
Ich wollte die Anzahl Dateien mittels "Do While / Loop"  nacheinander abarbeiten lassen, das ging aber erst, als ich am Ende anstatt "Workbooks(strFileName).Close SaveChanges:=True"  durch

"Workbooks(strFileName).Save"   und
"Workbooks(strFileName).Close"  ersetzt habe, keine Ahnung warum !

Hier noch einmal der Code.

Ich musste allerdings alle Dateien zuerst mit meinem VBA-Kennwort die Sperre öffnen, da ich keine Möglichkeit fand dies mittels eines Codes zu öffnen, und die Key-Funktionen gehen jedenfalls mit Excel 2013 nicht mehr.
Vielen Dank nochmals.
Liebe Grüße aus Innsbruck
Helmut

Code:

Sub Ändern_CB10_Code()         ' Die Sub des CB10 in allen TBs ändern
   
   Dim wb As Workbook
   Set wb = ActiveWorkbook
 
  prcStart wb
End Sub

Public Sub prcStart(wb As Workbook)
  Dim objVBComponents As Object, i As Integer, j As Integer
  With wb.VBProject    'alle Tabellen werden aufgerufen
     For Each objVBComponents In .VBComponents
        Select Case objVBComponents.Type
        Case 1   '2, 3        'Module, Klasssenmodule, Userforms
           '.VBComponents.Remove .VBComponents(objVBComponents.Name)  'wird für Module etc. verwendet
        Case 100       'Workbook, Sheets, Carts
           i = 0: j = 0
           Call prcFindProc("CommandButton10_Click", objVBComponents.CodeModule, i, j)  'Zu änderndes Modul
           'i = ab CommandButton10_Click
  If objVBComponents.CodeModule.Name = "DieseArbeitsmappe" Then
GoTo Ende
     End If
           If i > 0 And j > 0 Then
              Call prcDelete(objVBComponents.CodeModule, i, j) 'Löschen aller Zeilen des Moduls
              Call InsertProc(objVBComponents.CodeModule, i)
           End If
        End Select
     Next
Ende:
  End With

End Sub

Public Sub prcFindProc(strProc As String, objCodeModule As Object, intStartLine As Integer, intEndLine As Integer)
  Dim intLine As Integer, sLine As String
  With objCodeModule   'alle Tabellen werden aufgerufen
           
     For intLine = 1 To .CountOfLines
        If .ProcOfLine(intLine, 0) = strProc Then
           sLine = Trim(.Lines(intLine, 1))
           If intStartLine = 0 And InStr(1, sLine, strProc) > 0 And Left(sLine, 1) <> "'" Then
              intStartLine = intLine + 1
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") = 0 Then
              intEndLine = intLine
           ElseIf intStartLine > 0 And InStr(1, sLine, "End Sub") > 0 Then
              Exit For
           End If
        End If
     Next
     intEndLine = intEndLine - intStartLine + 1

  End With

End Sub

Public Sub prcDelete(objCodeModule As Object, intStartLine As Integer, intEndLine As Integer)
  objCodeModule.DeleteLines intStartLine, intEndLine       'Löschen des Inhaltes bis End Sub
End Sub
Sub InsertProc(objCodeModule As Object, i As Integer)       'Einfügen des neuen Codes
 
  With objCodeModule
    .InsertLines i + 0, "   Application.ScreenUpdating = False"
    .InsertLines i + 1, "   Dim tb"
    .InsertLines i + 2, "   tb = ActiveSheet.Name"
    .InsertLines i + 3, "   Änderung_Speich_1TB         'Modul"
    .InsertLines i + 4, "   Sheets(tb).Select"
    .InsertLines i + 5, "   druck=True"
    .InsertLines i + 6, "   ActiveSheet.PrintOut"
    .InsertLines i + 7, "   Application.ScreenUpdating = True"
  End With

End Sub