Hallo nochmal,
verwende jetzt den folgenden Code und habe leider immer noch ein Problem.
Nochmal kurz zum eigentlichem Nutzen des Codes.
Ich habe u.a. die Spalte Name und Betrag.
Name: Betrag:
Testname1 0,25
Testname1 -0,24
Testname2 0,30
Testname1 -0,01
Sobald die Summe (Saldo) der Beträge 0,00 ergibt, soll eine Verschiebung von Tabellenblatt1 in Tabellenblatt2 erfolgen. Also wenn ich hier im Beispiel Testname1 und -0,01 eingebe soll alles was auf den Namen Testname1 lautet in das andere Tabellenblatt verschoben werden.
Dank Holger funktioniert es nun auch z.B. 0,25 einzugeben. Das ging vorher nicht - alles was unter 0,50 war wurde sofort verschoben. Habe alles was auf "as Long" lautete auf "as Double" geändert.
Allerdings funktioniert die Verschiebung nun nicht mehr richtig. Denn wenn ich wie im Beispiel eingebe, müsste alles was Testname1 hat verschoben werden - tut es aber leider nicht.
Kann mir jemand sagen, was ich im Code falsch habe ???
Vielen Dank !!!!!!
Option Explicit
Public Suchbegriff As String 'Kontoname
Private Sub Worksheet_Change(ByVal Target As Range)
'wenn nicht gesetzt, wird ereignis immer wiederholt
Application.EnableEvents = False
Dim Ergebnis As Double 'gezählte Summe
Suchbegriff = ""
Ergebnis = 1
'wenn eingabe in spalte 8, dann zählen
If Target.Column = 8 Then
'suchbegriff von spalte 1 eingegebener zeile
Suchbegriff = Sheets(1).Cells(Target.Row, 1).Value
Ergebnis = WorksheetFunction.SumIf([A:A], Suchbegriff, [H:H])
'MsgBox Ergebnis
End If
'wenn ergebnis gleich 0 dann aktion
If Ergebnis <> 0 Then
Else
übertragen
End If
'wieder aufheben
Application.EnableEvents = True
End Sub
Sub übertragen()
Dim Ausgabezeile As Double 'von blatt erledigte konten
Dim letzteZeile As Double 'von blatt 1
Dim x As Double
Dim Kontrollsumme As Double 'übertragene Summe wird mitgezählt
Kontrollsumme = 0
'MsgBox Suchbegriff
letzteZeile = Sheets(1).Range("A65536").End(xlUp).Row
Ausgabezeile = Sheets("erledigte Konten").Range("A65536").End(xlUp).Row + 1
For x = 2 To letzteZeile
If Sheets(1).Cells(x, 1).Value = Suchbegriff Then
Kontrollsumme = Kontrollsumme + Sheets(1).Cells(x, 8).Value
'ausschneiden und einfügen
With Sheets(1)
.Rows(x).Copy
End With
Sheets("erledigte Konten").Range("A" & Ausgabezeile).Insert
Sheets(1).Rows(x).Delete shift:=xlUp
x = x - 1
Ausgabezeile = Ausgabezeile + 1
End If
Next x
If Kontrollsumme <> 0 Then
MsgBox "Achtung, übertragene Summe ist nicht 0", vbCritical, "Fehler bei Übertragung"
End If
End Sub
Sub test()
Application.EnableEvents = True
End Sub
------------------------------------------------------------------
Andi schrieb am 28.01.2008 10:04:09:
Hi Holger,
es funktioniert ! Ich danke Dir vielmals !!!!
Holger schrieb am 28.01.2008 09:53:53:
Hallo Andi,
Ersetze
Dim Ergebnis As Long 'gezählte Summe
durch z.B.
Dim Ergebnis As Double 'gezählte Summe
Ich habe dein Makro nicht getestet, bin mir aber sicher, dass das der Fehler ist.
Gruß
Holger
Andi schrieb am 28.01.2008 09:29:49:
Hallo Holger,
kannst Du mir dabei evtl. helfen. Um ehrlich zu sein kenne ich mich damit nicht wirklich aus!!
Holger schrieb am 28.01.2008 09:17:50:
Hallo Andi,
du hast Ergebnis als Long-Datentyp deklariert. Long sind Ganzzahl-Variablen, d.h. 0.25 wird 0, 0.51 wird 1. Verwende Single oder Double.
Gruß
Holger
Andi schrieb am 28.01.2008 08:38:40:
Hallo Zusammen,
vielleicht kann mir jemand weiterhelfen.
Es geht um eine Verschiebung von einem Tabellenblatt1 in Tabellenblatt2 wenn der Saldo von gleichlautenden Posten 0(null) ergibt. Ich habe allerdings bemerkt, dass bei der Verwendung von z.B. 0,25 sofort verschoben wird. Vermutlich rundet das Programm ab und erkennt den Posten als 0 und verschiebt. Ab 0,51 und darüber besteht diese Problematik nicht.
Kann mir jemand den Code so abändern, dass auch die Nachkommastellen richtig laufen ?
Code:
Option Explicit
Public Suchbegriff As String 'Kontoname
Private Sub Worksheet_Change(ByVal Target As Range)
'wenn nicht gesetzt, wird ereignis immer wiederholt
Application.EnableEvents = False
Dim Ergebnis As Long 'gezählte Summe
Suchbegriff = ""
Ergebnis = 1
'wenn eingabe in spalte 8, dann zählen
If Target.Column = 8 Then
'suchbegriff von spalte 1 eingegebener zeile
Suchbegriff = Sheets(1).Cells(Target.Row, 1).Value
Ergebnis = WorksheetFunction.SumIf([A:A], Suchbegriff, [H:H])
'MsgBox Ergebnis
End If
'wenn ergebnis gleich 0 dann aktion
If Ergebnis <> 0 Then
Else
übertragen
End If
'wieder aufheben
Application.EnableEvents = True
End Sub
Sub übertragen()
Dim Ausgabezeile As Long 'von blatt erledigte konten
Dim letzteZeile As Long 'von blatt 1
Dim x As Long
Dim Kontrollsumme As Long 'übertragene Summe wird mitgezählt
Kontrollsumme = 0
'MsgBox Suchbegriff
letzteZeile = Sheets(1).Range("A65536").End(xlUp).Row
Ausgabezeile = Sheets("erledigte Konten").Range("A65536").End(xlUp).Row + 1
For x = 2 To letzteZeile
If Sheets(1).Cells(x, 1).Value = Suchbegriff Then
Kontrollsumme = Kontrollsumme + Sheets(1).Cells(x, 8).Value
'ausschneiden und einfügen
With Sheets(1)
.Rows(x).Copy
End With
Sheets("erledigte Konten").Range("A" & Ausgabezeile).Insert
Sheets(1).Rows(x).Delete shift:=xlUp
x = x - 1
Ausgabezeile = Ausgabezeile + 1
End If
Next x
If Kontrollsumme <> 0 Then
MsgBox "Achtung, übertragene Summe ist nicht 0", vbCritical, "Fehler bei Übertragung"
End If
End Sub
Sub test()
Application.EnableEvents = True
End Sub
Vielen Dank für die Hilfe !!
Gruß
Andi
|