PDA

Vollständige Version anzeigen : Makro


Emina!
17.07.2014, 15:04
Hallo

Ich habe ein Makro zum grossen Teil mit dem Makroaufzeicher und mit eurer lieber Hilfe erstellt. Nun habe ich bemerkt das es wohl noch nicht perfekt ist. Ich kann dieses Makro nur einsetzten wenn die Tabelle weniger oder die gleiche Anzahl an Zeilen hat. Könnte mir da vieleicht jemand helfen mit meinem code

Sub Makro1()
'
' Makro1 Makro
'

'
Range("A:A,F:F,G:G,H:H,I:I,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("F2").Select
Dim Loletzte1 As Long
Dim Loletzte2 As Long
Dim Loletzte3 As Long
Loletzte1 = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows.Count)
Loletzte2 = IIf(IsEmpty(Cells(Rows.Count, 4)), Cells(Rows.Count, 4).End(xlUp).Row, Rows.Count)
Loletzte1 = Application.WorksheetFunction.Max(Loletzte1, Loletzte2)
Loletzte2 = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) + 1
Loletzte3 = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) + 1
Loletzte2 = Application.WorksheetFunction.Max(Loletzte3, Loletzte2)
Range(Range("C2"), Cells(Loletzte1, 4)).Copy Cells(Loletzte2, 1)
Dim lng_LastR As Long, Arr_V, i As Long
lng_LastR = Cells(Rows.Count, 5).End(xlUp).Row + 1
Arr_V = Range(Range("E2"), Cells(lng_LastR - 1, 5))
For i = LBound(Arr_V) To UBound(Arr_V)
Arr_V(i, 1) = Arr_V(i, 1) * -1
Next
Cells(lng_LastR, 5).Resize(UBound(Arr_V)) = Arr_V
Columns("C:D").Select
Range("D1").Activate
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Nr"
Range("A2").Select
Columns("A:A").ColumnWidth = 17.43
Range("A2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[1],RC[2])"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A2039")
Range("A2:A2039").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("E2").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"E:E"), Unique:=True
Columns("E:E").Select
Selection.NumberFormat = "0"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=SUMIF(C[-5],RC[-1],C[-2])"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F2039")
Range("F2:F2039").Select
Selection.NumberFormat = "#,##0.00"
Columns("F:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>0),""0"",RC[-1]))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<-0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>0),""0"",RC[-1]))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>-0.01),""0"",RC[-1]))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G2039")
Range("G2:G2039").Select
ActiveWindow.SmallScroll Down:=-3
Range("F14").Select
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0.00"
Range("F:F,A:D").Select
Range("D1").Activate
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Betrag"
Range("A2").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(i, 1) = 0 Then Rows(i).Delete
Next
Range("C1").Select
ActiveCell.FormulaR1C1 = "Haupt"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Kostenst."
Range("E1").Select
ActiveCell.FormulaR1C1 = "Soll-Betrag"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Haben-Betrag"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Währg"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],6)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C404")
Range("C2:C404").Select
Range("D2").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-2],7,8)"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D404")
Range("D2:D404").Select
Range("E2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]>0,RC[-4],"""")"
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E404")
Range("E2:E404").Select
Range("F2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-5]<0,RC[-5],"""")*-1,"""")"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F404")
Range("F2:F404").Select
Range("G2").Select
ActiveCell.FormulaR1C1 = "CHF"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G404")
Range("G2:G404").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Columns("A:B").Select
Range("B1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Bitte Periode eingeben"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.NumberFormat = "#,##0.00"
Columns("D:D").Select
Selection.NumberFormat = "#,##0.00"
Range("A1:E1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 14277081
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A2:B2").Select
Range("B2").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 32896
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("C2:E2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2:E2").Select
Selection.AutoFilter
Range("A1:E1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2:E2").Select
Selection.AutoFilter
Selection.AutoFilter

End Sub


Ich kenne mich wirklich nicht mit Makros aus und weiss nicht weiter, es steigt mir über den Kopf.

Wäre wirklich sehr froh wenn mir jemand helfen könnte. Wenn meine Tabelle mehrere Zeilen als die beigelegte hat, nimmt es nicht alle Werte.

Gruss


Anbei auch ein File zum Testen

Hasso
17.07.2014, 15:53
Hallo Eminal,Könnte mir da vieleicht jemand helfen mit meinem codeEs wäre hilfreich, wenn du kurz beschreiben würdest, was das Makro machen soll.

Die Datei, die du mitgeschickt hast, ist eine xlsx-Datei - in der gibt es kein Makro.

Emina!
17.07.2014, 16:02
Hallo Hasso

habe es jetzt nochmals hochgeladen mit Makro, das Endprodukt sollte genau so aussehen wie dieses. Nur unter der Spalte "Währg" sollten die Zeilen mit "CHF" auch nur bis zum Tabellenende gehen. Das Problem mit den Zeilen zieht sich leider durch das ganze Makro.

Das Grundproblem ist wenn ich eine Formel in eine bestimme Spalte schreibe, ziehe ich sie einfach bis zum Ende der Tabelle und das Makro märkt sich bis zu welcher Zeile, obwohl es immer bis zum Ende der Tabelle gehen soll, unabhängig davon wieviel Zeilen es sind.

Viele Grüsse
Emina!

Hasso
17.07.2014, 16:07
Hallo Eminal,

ich verstehe immer noch nicht, was du meinst.. Nur unter der Spalte "Währg" sollten die Zeilen mit "CHF" auch nur bis zum Tabellenende gehen.Ich sehe in dem ganzen Blatt weder eine Spalte "Währg" noch den Text "CHF".

Emina!
17.07.2014, 16:09
Wenn du das Makro laufen lässt, sieht man im Endprodukt diese Spalten

Gruss

Hasso
17.07.2014, 16:32
Hallo Emina!,

der Code ist ja grauenhaft und ich versuche auch gar nicht, da durchzusteigen. Dein Problem kannst du dadurch lösen, indem du die Zeile ActiveCell.FormulaR1C1 = "CHF"
auskommentierst oder löschst und am Ende des Codes folgendes anfügst:
'CHF in Spalte E schreiben:
lngLetzteZeile = Me.Cells(Rows.Count, 1).End(xlUp).Row
For intZeile = 3 To lngLetzteZeile
Cells(intZeile, "E") = "CHF"
Next intZeile


Hier der komplette Code, der bei mir funktioniert hat (meine Änderungen in rot):
Sub Makro1()
'
' Makro1 Makro
'

'
Range("A:A,F:F,G:G,H:H,I:I,K:K").Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("F2").Select
Dim Loletzte1 As Long
Dim Loletzte2 As Long
Dim Loletzte3 As Long
Loletzte1 = IIf(IsEmpty(Cells(Rows.Count, 3)), Cells(Rows.Count, 3).End(xlUp).Row, Rows.Count)
Loletzte2 = IIf(IsEmpty(Cells(Rows.Count, 4)), Cells(Rows.Count, 4).End(xlUp).Row, Rows.Count)
Loletzte1 = Application.WorksheetFunction.Max(Loletzte1, Loletzte2)
Loletzte2 = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) + 1
Loletzte3 = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) + 1
Loletzte2 = Application.WorksheetFunction.Max(Loletzte3, Loletzte2)
Range(Range("C2"), Cells(Loletzte1, 4)).Copy Cells(Loletzte2, 1)
Dim lng_LastR As Long, Arr_V, i As Long
lng_LastR = Cells(Rows.Count, 5).End(xlUp).Row + 1
Arr_V = Range(Range("E2"), Cells(lng_LastR - 1, 5))
For i = LBound(Arr_V) To UBound(Arr_V)
Arr_V(i, 1) = Arr_V(i, 1) * -1
Next
Cells(lng_LastR, 5).Resize(UBound(Arr_V)) = Arr_V
Columns("C:D").Select
Range("D1").Activate
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Nr"
Range("A2").Select
Columns("A:A").ColumnWidth = 17.43
Range("A2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[1],RC[2])"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A2039")
Range("A2:A2039").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("E2").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"E:E"), Unique:=True
Columns("E:E").Select
Selection.NumberFormat = "0"
Range("F2").Select
ActiveCell.FormulaR1C1 = "=SUMIF(C[-5],RC[-1],C[-2])"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F2039")
Range("F2:F2039").Select
Selection.NumberFormat = "#,##0.00"
Columns("F:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>0),""0"",RC[-1]))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<-0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>0),""0"",RC[-1]))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND(RC[-1]>0,RC[-1]<0.01),""0"",IF(AND(RC[-1]<0,RC[-1]>-0.01),""0"",RC[-1]))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G2039")
Range("G2:G2039").Select
ActiveWindow.SmallScroll Down:=-3
Range("F14").Select
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0.00"
Range("F:F,A:D").Select
Range("D1").Activate
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Betrag"
Range("A2").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(i, 1) = 0 Then Rows(i).Delete
Next
Range("C1").Select
ActiveCell.FormulaR1C1 = "Haupt"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Kostenst."
Range("E1").Select
ActiveCell.FormulaR1C1 = "Soll-Betrag"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Haben-Betrag"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Währg"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],6)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C404")
Range("C2:C404").Select
Range("D2").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-2],7,8)"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D404")
Range("D2:D404").Select
Range("E2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]>0,RC[-4],"""")"
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E404")
Range("E2:E404").Select
Range("F2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-5]<0,RC[-5],"""")*-1,"""")"
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F404")
Range("F2:F404").Select
Range("G2").Select
'ActiveCell.FormulaR1C1 = "CHF"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G404")
Range("G2:G404").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Columns("A:B").Select
Range("B1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Bitte Periode eingeben"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("C:C").Select
Selection.NumberFormat = "#,##0.00"
Columns("D:D").Select
Selection.NumberFormat = "#,##0.00"
Range("A1:E1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 14277081
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A2:B2").Select
Range("B2").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 32896
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("C2:E2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2:E2").Select
Selection.AutoFilter
Range("A1:E1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2:E2").Select
Selection.AutoFilter
Selection.AutoFilter

'CHF in Spalte E bis zur letzten Zeile der Tabelle schreiben:
lngLetzteZeile = Me.Cells(Rows.Count, 1).End(xlUp).Row
For intZeile = 3 To lngLetzteZeile
Cells(intZeile, "E") = "CHF"
Next intZeile
End Sub

Wenn du mal beschreiben würdest, was der Code eigentlich machen soll, könnte man das Ganze mit Sicherheit wesentlich übersichtlicher und effektiver programmieren. Aber das musst du wissen.

Emina!
17.07.2014, 17:22
Ja, ich weiss das der code grauenhaft ist... ich melde mich morgen nochmals dann kann ich die 3-4 heiklen Stellen besser erklären und ändern...

Danke vielmals für die Hilfe

Viele Grüsse

Emina!
18.07.2014, 07:47
Guten Morgen Hasso

habe jetzt meine Tabelle auseinander genommen. Ich hoffe dass es so ein wenig verständlicher ist. Tabelle 1 und 2 haben 2 Sheets. Im ersten wie es aussieht im zweiten wie die Tabelle sich erstellen soll

Tabelle1: dort ist im 2. Sheet die Spalte A neu eingefügt und hat eine Formel
Tabelle2: dort ist im 2. Sheet die Spalte F neu eingefügt mit Formeln

Kannst du mir da weiterhelfen wie ich das mit einem Makro machen kann unabhängig von der Anzahl der Zeilen, es soll halt immer bis zum Ende der Tabelle laufen.

Danke im Voraus

Hasso
18.07.2014, 10:03
Hallo Emina!,

zu 1.:Option Explicit

Sub SpaltemitFormelEinfuegen()

Dim lngLetzteZeile As Long
Dim lngZeile As Long

lngLetzteZeile = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

Columns("A:A").Insert Shift:=xlToRight
For lngZeile = 2 To lngLetzteZeile
Cells(lngZeile, "A").Formula = "=B" & lngZeile & "&C" & lngZeile
Next lngZeile

End Sub


Zu 2.:Option Explicit

Sub SpaltemitFormelEinfuegen()
Dim lngLetzteZeile As Long
Dim lngZeile As Long

lngLetzteZeile = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

Columns("F:F").Insert Shift:=xlToRight
For lngZeile = 2 To lngLetzteZeile
Cells(lngZeile, "F").Formula = "=SUMIF(A:A,E" & lngZeile & ",D:D)"
Next lngZeile

End Sub

Nur mal eine Frage: muss in Spalte A bzw F jeweils die Formel eingetragen werden oder würde es auch reichen, dort das Ergebnis der Formel einzutragen, als z.B. in Mappe 2 in Zelle F2 nicht=SUMMEWENN(A:A;E2;D:D)sondern-2,31921E-10

Emina!
18.07.2014, 10:16
Hallo Hasso

der Wert würde reichen, eigentlich brauche ich die Formeln nicht... Ich habe da noch 2 Tabellen mit dem gleichen Prinzip erstellt und dass wäre dann alles.

Wäre wirklich super wenn du mir da noch helfen könntest?

Vielen lieben Dank

Gruss

P.S. wenn ich nur ein Sheet habe das nicht beschriftet ist kann ich auch ActiveSheet schreiben oder?

Emina!
18.07.2014, 10:48
Hallo Hasso

bei mir funktioniert die Formel aus der 2. Tabelle leider nicht

Cells(lngZeile, "F").Formula = "=SUMIF(A:A,E" & lngZeile & ",D:D)"


Es kommt nur 0 in jeder Zelle...

in jeder Zelle steht =SUMMEWENN ( A : A ; E2040 ; D : D )

Gruss

Hasso
18.07.2014, 11:44
Hallo Emina!,

bei mir geht's.

Hier die Mappe:

Emina!
18.07.2014, 12:11
Hallo Hasso

bei mir jetzt auch, ich habe die zwei Makros in eins zusammmengefügt, deswegen hat es vorerst nicht funktioniert.

Danke dir!!

Wenn du evtl. Zeit hast, könntest du dir noch die Tabellen 3 und 4 anschauen?

Gruss

Hasso
18.07.2014, 12:55
Hallo Emina!,

ich habe jetzt noch mal den Code in allen 4 Tabellen so geändert, dass die Werte und nicht die Formeln in die entsprechenden Spalten eingetragen werden:

Emina!
18.07.2014, 13:02
Vielen Dank Hasso

Beim letzten (Tabelle4) kommt mir eine Fehler "Fehler beim Kompilieren, end with erwartet", weisst du woran das liegt?

Gruss

Hasso
18.07.2014, 13:06
Hallo Emina!,

wie die Fehlermeldung schon sagt: Es fehlt das End With (vor dem End Sub). Füge es in einer neuen Zeile ein und der Fehler ist behoben.

Emina!
18.07.2014, 13:17
Hallo Hasso

habe verstanden, weiss garnicht wieviel ich dir danken kann...

Vielen lieben Dank :)