bitte helft mir.
Excel stürtzt ab bei der Verarbeitung der auf die erste Sub-Kopfzeile folgenden ".insertLines"-Anweisung. Meine Vermutung ist, daß die Excel-Kodeprüfung in der Zieldatei einen Fehler wirft, den ich nicht weiß aufzufangen und zu verarbeiten.
Bei nachstehend vereinfachtem Kode ist die Abbruchstelle sobald die Verarbeitung bei Breakpoint auf .insertLines 3 um einen Schritt (F8) freigegeben wird. "134" steht nur aus Testgründen nach "3", da ich die Sub in der Zieldatei zuerst "komplettieren" wollte. Das selbe passiert aber auch, wenn "4" nach "3" verarbeitet werden soll. Das selbe passiert auch an der selben Stelle, wenn "Zeile .insertLines 2" fehlt.
Vorher wird die ganz unten stehende .insertLines-Anweisung in ("DieseArbeitsmappe").codeModule fehlerfrei und korrekt ausgeführt. Das "Zeilenumbruchverfahren" läßt sich wegen einer Beschränkung der maximalen Zeichenzahl und/oder Umbruchanzahl pro Anweisung nicht für die lange Einfügung verwenden.
Es gäbe wohl auch die Möglichkeit den einzufügenden Kode über eine Textdatei einzufügen. Auch ist es wohl möglich den einzufügenden Kode aus einem Modul der Datei zu laden, die derzeit die .insertLines-Anweisungen ausführen soll. Falls jemand dafür Hilfestellung geben will, würde ich mich freuen, denn dafür fehlen mir Kenntnisse.
Zum Zusammenhang sollte man wohl noch wissen, dass ich vor der Ausführung der codeModule-Anweisungen 17 Textdateien lade und zur manuellen Auswertung "vorkonfiguriere". Dazu gehört dann auch der für jede der neuen Arbeitsblätter einzufügende Kode. Der Kode funktioniert (bei manuellem Einkopieren) in der Zieldatei einwandfrei.
Haken bei "Zugriff auf Visual-Basic Projekt" ist gesetzt.
Haken bei "Verweis "Microsoft Visual Basic for Applications Extensibility 5.3" ist gesetzt.
(Leider bekomme ich die Formatierung für HTML nicht in den Griff.)
####Kode Beginn
With ActiveWorkbook.VBProject. _
VBComponents("Tabelle18").CodeModule
.InsertLines 2, "Option Explicit"
.InsertLines 3, "
Private Sub Worksheet_Change(ByVal Target As Excel.Range)"
.InsertLines 134, "End Sub
"
.InsertLines 4, "Dim help As Variant"
.InsertLines 5, "Dim colNr As Integer, rowNr As Integer"
.InsertLines 6, "colNr = Target.Column"
.InsertLines 7, "rowNr = Target.Row"
.InsertLines 8, "If rowNr = 6 Then"
.InsertLines 9, " If WorksheetFunction.IsText(Target.Value) Then"
.InsertLines 10, " Select Case UCase(Left(Target.Value, 1))"
.InsertLines 11, " Case ""R"""
.InsertLines 12, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 13, " .Interior.Color = vbRed"
.InsertLines 14, " .Font.Bold = True"
.InsertLines 15, " .Borders.Color = vbWhite"
.InsertLines 16, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 17, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 18, " End With"
.InsertLines 19, " Case ""B"""
.InsertLines 20, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 21, " .Interior.Color = RGB(128, 128, 255)"
.InsertLines 22, " .Font.Bold = True"
.InsertLines 23, " .Borders.Color = vbWhite"
.InsertLines 24, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 25, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 26, " End With"
.InsertLines 27, " Case ""G"""
.InsertLines 28, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 29, " .Interior.Color = vbGreen"
.InsertLines 30, " .Font.Bold = True"
.InsertLines 31, " .Borders.Color = vbWhite"
.InsertLines 32, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 33, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 34, " End With"
.InsertLines 35, " Case ""Y"""
.InsertLines 36, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 37, " .Interior.Color = vbYellow"
.InsertLines 38, " .Font.Bold = True"
.InsertLines 39, " .Borders.Color = vbBlack"
.InsertLines 40, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 41, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 42, " End With"
.InsertLines 43, " Case ""O"""
.InsertLines 44, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 45, " .Interior.Color = RGB(255, 64, 64) 'orange"
.InsertLines 46, " .Font.Bold = True"
.InsertLines 47, " .Borders.Color = vbWhite"
.InsertLines 48, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 49, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 50, " End With"
.InsertLines 51, " Case ""M"""
.InsertLines 52, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 53, " .Interior.Color = vbMagenta"
.InsertLines 54, " .Font.Bold = True"
.InsertLines 55, " .Borders.Color = vbWhite"
.InsertLines 56, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 57, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 58, " End With"
.InsertLines 59, " Case Else"
.InsertLines 60, " MsgBox (""1 gültige Eingaben sind:""" & vbLf & _
.InsertLines 61, " ""R B G Y O M und""" & vbLf & _
.InsertLines 62, " ""1 2 3 4 5 6""" & vbLf & _
.InsertLines 63, " ""Durch Löschen (kein Inhalt) wird die Formatierung aufgehoben"")"
.InsertLines 64, "End Select"
.InsertLines 65, "End If"
.InsertLines 66, " If WorksheetFunction.IsNumber(Target.Value) Then"
.InsertLines 67, " Select Case Target.Value"
.InsertLines 68, " Case ""1"""
.InsertLines 69, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 70, " .Interior.Color = vbRed"
.InsertLines 71, " .Font.Bold = True"
.InsertLines 72, " .Borders.Color = vbWhite"
.InsertLines 73, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 74, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 75, " End With"
.InsertLines 76, " Case ""2"""
.InsertLines 77, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 78, " .Interior.Color = RGB(128, 128, 255)"
.InsertLines 79, " .Font.Bold = True"
.InsertLines 80, " .Borders.Color = vbWhite"
.InsertLines 81, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 82, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 83, " End With"
.InsertLines 84, " Case ""3"""
.InsertLines 85, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 86, " .Interior.Color = vbGreen"
.InsertLines 87, " .Font.Bold = True"
.InsertLines 88, " .Borders.Color = vbWhite"
.InsertLines 89, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 90, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 91, " End With"
.InsertLines 92, " Case ""4"""
.InsertLines 93, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 94, " .Interior.Color = vbYellow"
.InsertLines 95, " .Font.Bold = True"
.InsertLines 96, " .Borders.Color = vbBlack"
.InsertLines 97, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 98, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 99, " End With"
.InsertLines 100, " Case ""5"""
.InsertLines 101, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 102, " .Interior.Color = RGB(255, 64, 64) 'orange"
.InsertLines 103, " .Font.Bold = True"
.InsertLines 104, " .Borders.Color = vbWhite"
.InsertLines 105, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 106, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 107, " End With"
.InsertLines 108, " Case ""6"""
.InsertLines 109, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 110, " .Interior.Color = vbMagenta"
.InsertLines 111, " .Font.Bold = True"
.InsertLines 112, " .Borders.Color = vbWhite"
.InsertLines 113, " .Borders.LineStyle = xlContinuous 'xlDot 'xlDash, xlContinuous"
.InsertLines 114, " .Borders.Weight = xlThin 'xlThick, xlMedium, xlThin, xlWeightHairline, xlWeightThin"
.InsertLines 115, " End With"
.InsertLines 116, " Case Else"
.InsertLines 117, " MsgBox (""1 gültige Eingaben sind:""" & vbLf & _
.InsertLines 118, " ""R B G Y O M und""" & vbLf & _
.InsertLines 119, " ""1 2 3 4 5 6""" & vbLf & _
.InsertLines 120, " ""Durch Löschen (kein Inhalt) wird die Formatierung aufgehoben"")"
.InsertLines 121, "End Select"
.InsertLines 122, "End If"
.InsertLines 123, " If Target.Value = """" Then"
.InsertLines 124, " With Range(Cells(1, colNr), Cells(12000, colNr))"
.InsertLines 125, " .Interior.Pattern = xlPatternNone ' xlPatternGrey16 funktioniert nicht, setzt aber auf ohne Pattern zurück"
.InsertLines 126, " .Interior.ColorIndex = xlNone"
.InsertLines 127, " .Font.Bold = False"
.InsertLines 128, " .Borders.Color = vbBlack"
.InsertLines 129, " .Borders.LineStyle = xlDot 'xlDash, xlContinuous"
.InsertLines 130, " End With"
.InsertLines 131, " End If"
.InsertLines 132, ""
.InsertLines 133, "End If"
'.InsertLines 134, "End Sub
"
End With
####Kode Ende
### Kode Beginn wird vor ("Tabelle18").codeModule ausgeführt
With ActiveWorkbook.VBProject. _
VBComponents("DieseArbeitsmappe").CodeModule
StartLine = .countoflines + 1
.InsertLines StartLine, "Option Explicit" & vbLf & _
"Public adrOld As String" & vbLf & _
Private Sub Workbook_Activate()" & vbLf & _
" adrOld = ActiveCell.Address" & vbLf & _
"End Sub
" & vbLf & _
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
_
_
" adrOld = ActiveCell.Address" & vbLf & _
"End Sub
" & vbLf & _
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbLf & _
" adrOld = Target.Address" & vbLf & _
"End Sub
" & vbLf & _
Private Sub Workbook_WindowActivate(ByVal Wn As Window)" & vbLf & _
" adrOld = Wn.ActiveCell.Address" & vbLf & _
"End Sub
" & vbLf & _
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)" & vbLf & _
"' MsgBox (""Workbook_SheetDeactivate5"")" & vbLf & _
" Dim ziel As String" & vbLf & _
" ziel = ActiveCell.Address" & vbLf & _
" On Error Resume Next" & vbLf & _
" ziel = Application.InputBox(""Sprungziel mit OK bestätigen oder zuerst ändern"", "" _
_
Sprungziel prüfen"", adrOld)" & vbLf & _
" ActiveSheet.Range(ziel).Activate" & vbLf & _
"End Sub
"
End With
####Kode Ende :-)