AW: VBA Formate aus darüberliegender Zeile übernehmen
25.04.2007 21:03:22
Peter
Hallo Daniel,
der Code befindet sich in Formulare Userform "frmEingabe_neue_Zahlung".
Auf meinem Tabellenblatt habe ich ein Commandbutton der folgendes Makro startet (makro befindet sich in Tabelle2 Cashflow):
Private Sub neue_Zahlung_Click()
SpeedUp (True)
If MsgBox("Wollen Sie eine neue Zahlung einfügen ?", vbOKCancel + _
vbQuestion, "Achtung!") = 1 Then
frmEingabe_neue_Zahlung.Show
End If
SpeedUp (False)
End Sub
Nach "OK" zeigt sich die Userform "frmEingabe_neue_Zahlung".
Dort kann man diverse Einträge machen, die dann nach dem man den Commandbutton "cmdOK" angeklickt hat in bestimmte Spalte in die erste leere Zeile am Ende der Tabelle eingetragen werden.
Da sich die Tabelle dann um eine Zeile verlängert hat müssen Rahmen etc. in die neue Zeile übernommen werden.
Danach wird, je nach dem welches neue Datum in Spalte A in der neue Zeile steht die Tabelle aufsteigend sortiert.
Wenn ich den ganzen Inhalt (Formeln, Formate, Werte usw.) kopieren würde, werden die über die Userform neu eingetragenen Werte überschrieben. Den Code für das kopieren nur der Formeln brauche ich deswegen. Meine VBA-Kenntnisse sind nicht ausreichend um das Problem mit den Formaten zu lösen.
Code der Userform
Private Sub cmdOK_Click()
Dim cell As Range
Dim a As Long
Dim lbMsg As Byte
If Not IsDate(txtDatum.Text) = True Then
lbMsg = MsgBox("Geben Sie ein gültiges Datum ein", vbExclamation, "falsche Eingabe") _
txtDatum.Text = ""
txtDatum.SetFocus
cmdOK.Enabled = False
Exit Sub
End If
If Not IsDate(txtfaellig_zum.Text) = True Then
lbMsg = MsgBox("Geben Sie ein gültiges Datum ein", vbExclamation, "falsche Eingabe") _
txtfaellig_zum.Text = ""
txtfaellig_zum.SetFocus
cmdOK.Enabled = False
Exit Sub
End If
If cboAusgang_Eingang_Gesellschaft_Konto.Text = "Ausgang" Then
If Val(txtBetrag_Gesellschaft_Konto.Text) > 0 Then
lbMsg = MsgBox("Geben Sie einen negativen Wert ein", vbExclamation, " _
falsche Eingabe")
txtBetrag_Gesellschaft_Konto.Text = ""
txtBetrag_Gesellschaft_Konto.SetFocus
cmdOK.Enabled = False
Exit Sub
End If
If Val(txtBetrag_MwSt.Text) 0 Then
lbMsg = MsgBox("Geben Sie einen negativen Wert oder 0 ein", vbExclamation, " _
falsche Eingabe")
txtBetrag_MwSt.Text = ""
txtBetrag_MwSt.SetFocus
cmdOK.Enabled = False
Exit Sub
End If
End If
Range("A:A").Find("", after:=[A6]).Activate
ActiveCell.Value = CDate(Me.txtDatum)
ActiveCell.Offset(0, 1).Value = CDate(Me.txtfaellig_zum)
ActiveCell.Offset(0, 2).Value = Me.cboArt
ActiveCell.Offset(0, 3).Value = Me.txtGegenseite
ActiveCell.Offset(0, 4).Value = Me.txtZahlungsgrund
If Me.cboGesellschaft_Konto = "DA/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 5).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 6).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 13).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 14).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Kontokorrent Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 17).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Kontokorrent Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 18).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Kontokorrent Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 21).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Kontokorrent Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 22).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Treuhand Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 25).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Treuhand Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 26).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Treuhand Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 29).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 10).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "DA/Treuhand Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 30).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 9).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "AS/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 33).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AS/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 34).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "LB/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 37).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 42).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LB/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 38).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 41).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LB/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 45).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 42).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LB/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 46).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 41).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LHB/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 49).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 54).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LHB/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 50).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 53).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LHB/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 57).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 54).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "LHB/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 58).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
ActiveCell.Offset(0, 53).Value = CDec(Me.txtBetrag_MwSt)
End If
If Me.cboGesellschaft_Konto = "AW/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 61).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Allgemeines Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 62).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 65).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Allgemeines Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 66).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Treuhand Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 69).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Treuhand Lewa" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 70).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Treuhand Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Ausgang" Then
ActiveCell.Offset(0, 73).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
If Me.cboGesellschaft_Konto = "AW/Treuhand Euro" And Me. _
cboAusgang_Eingang_Gesellschaft_Konto = "Eingang" Then
ActiveCell.Offset(0, 74).Value = CDec(Me.txtBetrag_Gesellschaft_Konto)
End If
Unload Me
a = Cells(65536, 1).End(xlUp).Row - ActiveCell.Row + 1
For Each cell In Rows(ActiveCell.Row - 1).SpecialCells(xlCellTypeFormulas, 23)
cell.Copy Destination:=cell.Offset(1, 0).Resize(a, 1)
'For Each cell In Rows(ActiveCell.Row - 1) '.SpecialCells(xlCellTypeFormulas, 23)
'cell.AutoFill Destination:=cell.Offset(1, 0), Type:=xlFillFormats
Next
Range("A6:CM2000").Sort Key1:=Range("A6"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns(1).Find(CDate(Me.txtDatum)).Select
End Sub
Kannst du mir entsprechende Änderungen am Code machen?
meine Datei: https://www.herber.de/bbs/user/42025.xls
Danke im Voraus
Grüße aus Berlin