Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datumsvergleich

Forumthread: Datumsvergleich

Datumsvergleich
16.12.2005 19:46:12
Peter
Hallo,
ich habe folgendes Problem:
In der Spalte „A“ der „Tabelle1“ stehen Datumswerte.
Ist eine Datumsangabe aus der drüberliegenden Zeile aus Spalte „A“ vom
Vortag, soll diese in die Spalte “A“ der “Tabelle2“ kopiert werden.
Als Ergebnis sollen keine aufeinanderfolgenden Tage in der gleichen Tabelle stehen.
z.B.
Tabelle1 - Tabelle2
12.01.05 - 13.01.05
27.01.05 - 28.01.05
29.01.05 -
02.02.05 -
Ich habe folgenden Lösungsansatz:
Jedoch funktioniert die Sache nicht, wenn als letzter und vorletzter Eintrag
aufeinanderfolgende Tage stehen.

Sub PruefenKopieren()
Dim intCounter As Integer, intLastRow As Integer
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For intCounter = 2 To intLastRow
If CDbl(Cells(intCounter, 1).Value) = CDbl(Cells(intCounter + 1, 1).Value - 1 And _
CDbl(Cells(intCounter, 1).Value) Mod 2 = 0 Then
'Worksheets("Tabelle2").Cells(intCounter, 2).Value = Cells(intCounter, 1).Value
Cells(intCounter, 2).Value = Cells(intCounter, 1).Value
': Rows(intCounter).Delete
End If
Next intCounter
End Sub

Danke im voraus Peter
Anzeige

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datumsvergleich
17.12.2005 01:54:19
Josef
Hallo Peter!
Probier's mal so!
Sub CheckDateAndCut()
Dim objWS1 As Worksheet, objWS2 As Worksheet
Dim lngLastRow As Long, lngRow As Long, lngCopyRow As Long

On Error GoTo ErrExit
Application.ScreenUpdating = False

Set objWS1 = Sheets("Tabelle1")
Set objWS2 = Sheets("Tabelle2")

lngLastRow = objWS1.Range("A65536").End(xlUp).Row
lngCopyRow = 2

For lngRow = 2 To lngLastRow - 1
  If objWS1.Cells(lngRow, 1).Value = objWS1.Cells(lngRow + 1, 1).Value - 1 Then
    objWS1.Cells(lngRow + 1, 1).Copy objWS2.Cells(lngCopyRow, 1)
    objWS1.Cells(lngRow + 1, 1).Delete (xlUp)
    lngCopyRow = lngCopyRow + 1
  End If
Next

ErrExit:
Application.ScreenUpdating = True

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Datumsvergleich - Danke Josef
18.12.2005 10:34:31
Peter
Danke für die schnelle Hilfe.
Code funktioniert einwandfrei.
Peter
;

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige