AW: Wir wären dankbar, wenn wir den Code kennen, owT
02.08.2017 14:01:51
Herbert
Die ganze Prozedur ist folgende :
Der Fehler passiert hier => '(!!! Die folgende Programmlinie funktionniert nicht)
Vielen Dank für einen Tipp. Gruss Herbert
Sub Anpassenbuchungen()
Application.ScreenUpdating = False
' In welcher Sprache soll die Ausgabe erfolgen (Z64,90,154,155 + eingefügt anpassen)?
Dim Sprache As String
Range("A1").Select
If Range("A1") = "Liste des écritures" Then
Sprache = "F"
Else
Sprache = "D"
End If
' Uebernahme der zweiten Buchungstextzeile
Range("E4").Select
ActiveCell.FormulaR1C1 = "=IF(R[1]C[-2]"""","""",R[1]C[-1])"
ActiveCell.Offset(1, 0).Range("A1").Select
Range("E4").Select
' Kopiert die Formel bis zur Zelle 30000
Selection.Copy
Range("E5:E30000").Select
ActiveSheet.Paste
' Nimmt die Formel raus und behaltet nur den Inhalt
Columns("E:E").Select
Range("E3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Einfügen einer Kolonne und zusammenfügen des Buchungstextes
Columns("F:F").Select
Range("F2").Activate
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("F4").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
Range("F4").Select
Selection.Copy
Range("F5:F30000").Select
ActiveSheet.Paste
' Nimmt die Formel raus und behaltet nur den Inhalt
Columns("F:F").Select
Range("F3").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Löschen unntötiger Spalten und der 1. und 2. Linie
Columns("D:E").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("f:h").Select
Selection.Delete Shift:=xlToLeft
Columns("A:G").Select
Columns("A:G").EntireColumn.AutoFit
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
'Sortieren nach Kontonummer und Datum
Rows("2:30000").Select
ActiveWorkbook.Worksheets("Buchungen").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Buchungen").Sort.SortFields.Add Key:=Range _
("C2:C30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Buchungen").Sort.SortFields.Add Key:=Range _
("B2:B30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Buchungen").Sort
.SetRange Range("A2:L30000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Füge den Saldo der Buchungen ein
Range("H1").Select
If Sprache = "F" Then
ActiveCell.FormulaR1C1 = "Solde"
Else
ActiveCell.FormulaR1C1 = "Saldo"
End If
Range("H2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-5]=R[-1]C[-5],R[-1]C+RC[-2]-RC[-1],RC[-2]-RC[-1])"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Offset(-1, 0).Range("A1").Select
Selection.Copy
ActiveCell.Offset(1, 0).Range("A1:A30000").Select
ActiveSheet.Paste
'Springe auf die letzte Zahlenzeile um die anderen zu Löschen
Range("A1").Select
Selection.End(xlUp).Select
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=3
ActiveCell.Offset(1, 0).Rows("1:30000").EntireRow.Select
Selection.ClearContents
ActiveCell.Select
'Kolonne H formatieren und Formel herausnehmen sowie Ueberschrift Kolonne D
Columns("H:H").Select
Selection.Style = "Comma"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
If Sprache = "F" Then
ActiveCell.FormulaR1C1 = "Texte d'écriture"
Else
ActiveCell.FormulaR1C1 = "Buchungstext"
End If
'Ueberschriftszeile formatieren und Kader erstellen
Range("A1:H1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.FontStyle = "Kursiv"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Einfügen eines Titels
Rows("1:1").Select
' (!!! Die folgende Programmlinie funktionniert nicht)
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
Dim NameGesellschaft As String
Dim Periode As String
If Sprache = "F" Then
NameGesellschaft = InputBox("Quel est le nom de la société ?", "à indiquer le nom")
Periode = InputBox("Il s'agit des écritures de la période ?", "période ")
Else
NameGesellschaft = InputBox("Wie heisst die Gesellschaft ?", "bitte Name eingeben")
Periode = InputBox("Für welche Periode sind diese Buchungen ?", "Periode ")
End If
Range("A1").Value = NameGesellschaft
Range("E1").Value = Periode
'Einfügen eines Filters um die Kontis zu isolieren
Rows("2:2").Select
Selection.AutoFilter
Application.ScreenUpdating = True
Range("A1").Select
End Sub