Sub für CommandButton ändern

[Winny]

Hi

es gab doch noch Fehler die mir bei meinen Tests nicht aufgefallen sind, hier eine korrigierte und auch verbesserte Version

Code:

Option Explicit

Sub tst()
  Dim wb As Workbook

  Set wb = Workbooks("Testmappe.xlsm")
  prcStart wb
End Sub

'Nach http://www.office-loesung.de/ftopic192212_15_0_asc.php von Lukas Mosimann

Public Sub prcStart(wb As Workbook)
  Dim objVBComponents As Object, i As Integer, j As Integer
  With wb.VBProject
     For Each objVBComponents In .VBComponents
        Select Case objVBComponents.Type
        Case 1, 2, 3 'Module, Klasssenmodule, Userforms
           '.VBComponents.Remove .VBComponents(objVBComponents.Name)
        Case 100 'Workbook, Sheets, Carts
           i = 0: j = 0
           Call prcFindProc("CommandButton10_Click", objVBComponents.CodeModule, i, j)
           If i > 0 And j > 0 Then
              Call prcDelete(objVBComponents.CodeModule, i, j)
              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
     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
End Sub

Sub InsertProc(objCodeModule As Object, i As Integer)
  With objCodeModule
     .InsertLines i + 0, "   Dim tb"
     .InsertLines i + 1, "   tb = ActiveSheet.Name"
     .InsertLines i + 2, "   Änderung_Speich_1TB         'Modul"
     .InsertLines i + 3, "   Sheets(tb).Select"
     .InsertLines i + 4, "   ActiveSheet.PrintOut"
  End With
End Sub

[heli]

Hallo Winny,

vielen Dank für Deine Antwort.
Ich habe 12 Monatsblätter pro Datei zur Änderung und im ersten Blatt (Jänner) passt die Zeilenanzahl, aber die anderen haben die beiden ersten Zeilen zu viel.
Hier der geänderte Code ab dem zweiten Tabellenblatt:

Code:

Private Sub CommandButton10_Click()

Application.ScreenUpdating = False

Änderung_Speich_1TB         'Modul
  Application.ScreenUpdating = False
  Dim tb
  tb = ActiveSheet.Name
  Änderung_Speich_1TB         'Modul
  Sheets(tb).Select
  ActiveSheet.PrintOut
  Application.ScreenUpdating = True
End Sub

 Vielen Dank für Deine Hilfr.
Liebe Grüße
Helmut

[Winny]

Hallo Helmut

wenn das die geänderte Prozedur ist dann fällt auf dass das Application.ScreenUpdating = True am Ende nicht in meinem Code mit drin ist. Hast Du denn evtl. daran geändert? Eine Möglichkeit wäre dein Blatt zur Verfügung zu stellen, die Blätter sollten erhalten bleiben allerdings könntest Du die Daten komplett entfernen, es geht ja nur um die Makros

[heli]

Hallo Winny,

vielen herzlichen Dank, jetzt hat es funktioniert, super.
Die erste und letzte Zeile habe ich hinzugefügt, passt aber alles.

Liebe Grüße
Helmut