24.10.2011, aktualisiert um 14:14:01 Uhr

6375

Excel VB Datum prüfen

Hallo,
ich wurde dazu degradiert eine Excel Datei zu ertsellen die folgendes kann...

PS
Ich bin vollkommener Neuling in VB

... Man soll alle Gegenstände in eine Tabelle eintragen können und diese Gegenstände sollen den AUTOMATISCH in die jeweiligen Raumlisten bzw Wertlisten kopiert werden.
Soweit so gut und es Funktioniert auch alles super ABER an einer Sache scheiterts bei mir.

JETZT das Problem.

Ab der Zeile 26 bis Zeile 43 wird der Wert geprüft ob der Wert von bis größer kleiner ist.
Aber der soll in der SELBEN Zeile in einer anderen Spalte vorher prüfen ob ein Datum nicht vor dem 31.12.2007 ist.

Dies ist der code für das Auswerten einer Wertetabelle.

Public Sub FlaechenWertAuswertung_1()
'Ausblenden der Macroaktionen  
Application.ScreenUpdating = False

'Deklarieren der Variablen  
Dim cell As Range
Dim ExitFor As Integer
ExitFor = 0

'Deklarieren des Tabellenschleifenzählerwertes  
Dim tblz As Integer
Dim tblr As String
tblz = 8
tblr = "8:65536"  

'Deklarieren der Tabellenschleifenzähler  
Dim tblz001 As Integer

'Setzen der Tabellenschleifenzähler  
tblz001 = tblz

'Löschen der alten Daten  
tbla001.Rows(tblr).ClearContents

'Schreiben der neuen Daten  
For Each cell In Tabelle1.Range("J8:J65536")  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
If cell.Value >= 0.01 Then
    If cell.Value < 410 Then
        cell.EntireRow.Copy
        tbla001.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
        tblz001 = tblz001 + 1
    End If
End If
Next cell
Application.ScreenUpdating = True
End Sub

Währe echt Dankbar für Hilfe

Mit freundlichen Grüßen
DasBreaker

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 175169

Url: https://administrator.de/contentid/175169

Ausgedruckt am: 22.11.2024 um 06:11 Uhr

11 Kommentare

Neuester Kommentar

Moin,

wie wäre es mit folgendem:

zuerst vorher im code die Variable Limit deklarieren und den Wert 31.12.2007 zuweisen:

limit = Format("31.12.2007", "dd.mm.yyyy")

In der Schleife dann prüfen, ob die Differenz in Tagen größer 0 ist:

If DateDiff("d", limit, cell) > 0 Then  
...
Else
...
Endif

cell ist hierbei die aktuell ausgewählte Zelle.
Ich gehe davon aus, dass diese bereits als Datum formatiert ist.

Gruß,
DB

Okay Danke schonmal

jetzt habe ich schon mal die Anfrage ob Datum < > = ist ^^
Aber wie sage ich dem noch das der in der Spalte F (ist immer F) nachschauen soll?
Weil der ja in dem Moment in der Spalte J ist und den Wert ausliest oder sehe ich da gerade was falsch ich würde das jetzt so machen.

For Each cell In Tabelle1.Range("J8:J65536")  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
limit = Format("31.12.2007", "dd.mm.yyyy")  
If DateDiff("d", limit, cell) > 0 Then 'statt cell muss der die Spalte F in der selben Zeile einlesen  
    If cell.Value > 150.01 Then
        If cell.Value < 1000 Then
            cell.EntireRow.Copy
            tbla002.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
            tblz001 = tblz001 + 1
        End If
    End If
End If

Next cell

EDIT: wofür steht das "d" bei DateDiff?

Ich würde das dann ein bisschen umschreiben:

limit = Format("31.12.2007", "dd.mm.yyyy")  
For i = 8 To 65536
cell = Tabelle1.Range("J" & i)  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
If DateDiff("d", limit, Tabelle1.Range("F" & i)) > 0 Then  
    If cell.Value > 150.01 Then
        If cell.Value < 1000 Then
            cell.EntireRow.Copy
            tbla002.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
            tblz001 = tblz001 + 1
        End If
    End If
End If
Next i

PS: d bei DateDiff steht für days == Tage

Danke

Noch eine kleine Frage

*für mein Verständniss*

Tabelle1.Range("F" & i)
F ist die Spalte
und i die Zeile könnte man nicht einfach auf cell abfragen in welcher Zeile cell gerade ist ?

damit es dan so ist ?

'Schreiben der neuen Daten  
For Each cell In Tabelle1.Range("J8:J65536")  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
limit = Format("31.12.2007", "dd.mm.yyyy")  
region = Tabelle1.Range("F" & cell.AKTUELLE ZEILE) <-------------------------------------------------------------  
If DateDiff("d", limit, region) > 0 Then  
    If cell.Value > 150.01 Then
        If cell.Value < 1000 Then
            cell.EntireRow.Copy
            tbla002.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
            tblz001 = tblz001 + 1
        End If
    End If
End If
Next cell
Application.ScreenUpdating = True
End Sub

Das könnte theoretisch gehen.
Ich weiß aber nicht, ob vba dafür eine Funktion bietet.

Gruß,
DB

Warte mal ich habe doch die aktuelle Zeile
sihe tblz001 ???
könnte es sein das ich sowas schon unwissentlich habe ?

OKAY
HABE ES HIN BEKOMMEN DANKÖÖÖÖÖÖ :D

Auch wenn ich das < und > dei DiffDate austauchen musste

hier der code

Public Sub FlaechenWertAuswertung_1()
'Ausblenden der Macroaktionen  
Application.ScreenUpdating = False

'Deklarieren der Variablen  
Dim cell As Range
Dim ExitFor As Integer
ExitFor = 0

'Deklarieren des Tabellenschleifenzählerwertes  
Dim tblz As Integer
Dim tblr As String
tblz = 8
tblr = "8:65536"  

'Deklarieren der Tabellenschleifenzähler  
Dim tblz001 As Integer

'Setzen der Tabellenschleifenzähler  
tblz001 = tblz

'Löschen der alten Daten  
tbla001.Rows(tblr).ClearContents

'Schreiben der neuen Daten  
For Each cell In Tabelle1.Range("J8:J65536")  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
limit = Format("31.12.2007", "dd.mm.yyyy")  
If DateDiff("d", limit, Tabelle1.Range("F" & tblz001)) < 0 Then  
    If cell.Value >= 0.01 Then
        If cell.Value < 410 Then
            cell.EntireRow.Copy
            tbla001.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
            tblz001 = tblz001 + 1
        End If
    End If
End If
Next cell
Application.ScreenUpdating = True
End Sub

EDIT:
es muss...

If DateDiff("d", limit, Tabelle1.Range("F" & tblz001)) <= 0 Then   

... sein da sonst der 31.12. nicht mit berechnet wird :D

Vielen Dank
Mit freundlichen Grüßen
DasBreaker

*arg*

vieleicht sollte man vorher ausgiebig Testen bevor man sagt es Klappt.

leider habe ich iwo mit dem Datum immernoch ein Fehler.
EINGABE

x = was ausgegeben werden MUSS

150,00 € x
31.12.2006 150,00 € x
31.12.2007 150,00 € x
01.01.2008 150,00 €
01.01.2009 150,00 €
500,00 €
31.12.2006 500,00 €
31.12.2007 500,00 €
01.01.2008 500,00 €
01.01.2009 500,00 €

AUSGABE
150,00 €
31.12.07 150,00 €

[leer] 150,00 €
31.12.2006 150,00 €
31.12.2007 150,00 €
01.01.2008 150,00 €
01.01.2009 150,00 €
[leer] 500,00 €
31.12.2006 500,00 €
31.12.2007 500,00 €
01.01.2008 500,00 €
01.01.2009 500,00 €

OKAY das habe ich hin bekommen war nen FAIL meiner seits
Aber nun zum nächsten Problem:
zB die Werte oben sind die testwerte

und das ist der Code

limit = Format("31.12.2007", "dd.mm.yyyy")  
If DateDiff("d", limit, Tabelle1.Range("F" & tblz001)) > 0 Then ' Alles was über dem 31.12.2007 ist  
    If cell.Value >= 150.01 Then 'Alles was größer oder gleich 150,01€ ist  
        If cell.Value <= 1000 Then 'Alles was kleiner oder gleich 1000€ ist  
            cell.EntireRow.Copy
            tbla002.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
            tblz001 = tblz001 + 1
        End If
    End If
End If

Aber die ausgabe ist leer o.O
Was mache ich falsch ?

OK ich habe den Fehler doch gefunden Quellcode gibs morgen da ich die erlösung 5 min vor arbeitsschluss gefunden habe.

Zitat von @DasBreaker:

OK ich habe den Fehler doch gefunden Quellcode gibs morgen da ich die erlösung 5 min vor arbeitsschluss gefunden habe.

Guten Morgen wie versprochen der Code

Public Sub FlaechenWertAuswertung_1()
'Ausblenden der Macroaktionen  
Application.ScreenUpdating = False

'Deklarieren der Variablen  
Dim cell As Range
Dim ExitFor As Integer
ExitFor = 0

'Deklarieren des Tabellenschleifenzählerwertes  
Dim tblz As Integer
Dim tblr As String
tblz = 8
tblr = "8:65536"  

'Deklarieren der Tabellenschleifenzähler  
Dim tblz001 As Integer

'Setzen der Tabellenschleifenzähler  
tblz001 = tblz

'Löschen der alten Daten  
tbla001.Rows(tblr).ClearContents

'Schreiben der neuen Daten  
For Each cell In Tabelle1.Range("J8:J65536")  
If cell.Value = "" Then  
    ExitFor = ExitFor + 1
    If ExitFor >= 200 Then
        Exit For
    End If
End If
If Not cell.Value = "" Then  
    ExitFor = 0
End If
limit = Format("31.12.2007", "dd.mm.yyyy")  
If Not Tabelle1.Range("F" & tblz) = "" Then  
    If DateDiff("d", limit, Tabelle1.Range("F" & tblz)) <= 0 Then  
        If cell.Value >= 0.01 Then
            If cell.Value < 410 Then
                cell.EntireRow.Copy
                tbla001.Cells(tblz001, 1).PasteSpecial , Paste:=xlPasteValues
                tblz001 = tblz001 + 1
            End If
        End If
    End If
End If
tblz = tblz + 1
Next cell
Application.ScreenUpdating = True
End Sub