Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 21:51:33
Idee für Grafik
26.04.2024 21:29:07
PQ zufällige Reihenfolge
26.04.2024 17:18:47
Große Datenmenge in komplexes Diagramm verpacken
26.04.2024 16:22:47
Aktualisierung Verknüpfung bei geschlossener Quelldatei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1748to1752
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1748to1752
1748to1752
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Datumfinden/Anderes auswählen

Datumfinden/Anderes auswählen
09.04.2020 14:41:50
Max
Guten Tag liebe VBA-Gemeinschaft,
Folgendes Problem: wenn in Spalte A das Datum aus Zelle G7 (A_1) nicht vorhanden ist und im Schlimmsten Fall erst ein Datum ein Paar Jahre später zu finden ist dann hängt sich der nachfolgende Code immer auf
bzw. braucht ewig.
Zur Frage: wie ginge das schneller ?
Userbild
A_1 = CDbl(Range("G7"))
B_1 = CDbl(Range("G8"))
On Error Resume Next
If Not IsError(Application.Match(A_1, Range("A:A"), 0)) Then
A = Application.Match(A_1, Range("A:A"), 0)
Else
Do
A_1 = A_1 + 1
A = Application.Match(A_1, Range("A:A"), 0)
Loop Until Not IsError(Application.Match(A_1, Range("A:A"), 0))
End If
If Not IsError(Application.Match(B_1, Range("A:A"), 0)) Then
B = Application.Match(B_1, Range("A:A"), 0)
Else
Do
B_1 = B_1 - 1
B = Application.Match(B_1, Range("A:A"), 0)
Loop Until Not IsError(Application.Match(B_1, Range("A:A"), 0))
End If

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datumfinden/Anderes auswählen
09.04.2020 15:54:28
ChrisL
Hi Max
Der dritte Parameter von VERGLEICH/Match anpassen. Bei dir 0 = genaue Übereinstimmung. Wenn du -1 kleiner als oder +1 grösser als verwendest, dann findest du den nächstgelegenen Wert. Die Liste muss dazu sortiert sein.
Somit benötigst du dann gar keine Schleife, was den Prozess stark beschleunigen sollte.
cu
Chris
AW: Datumfinden/Anderes auswählen
09.04.2020 16:55:37
Max
Schon mal danke an dich Chris das löst zumindest ein Problem
aber wie man auf dem Bild sehen kann sind die Daten mit dem Datum aufsteigend sortiert und für die Match-Vergleichstypen müssen die Werte auf,bzw absteigend sortiert sein.
A_1 = CDbl(Range("G7"))
B_1 = CDbl(Range("G8"))
On Error Resume Next
If Not IsError(Application.Match(A_1, Range("A:A"), 0)) Then
A = Application.Match(A_1, Range("A:A"), 0)
Else
A = Application.Match(A_1, Range("A:A"), -1)
End If
If Not IsError(Application.Match(B_1, Range("A:A"), 0)) Then
B = Application.Match(B_1, Range("A:A"), 0)
Else
B = Application.Match(B_1, Range("A:A"), 1)
End If
Für B also kein Problem nur bei A spinnt er noch rum
Mit freundlichen Grüßen
Max
Anzeige
AW: Datumfinden/Anderes auswählen
09.04.2020 17:06:29
ChrisL
Hi Max
Lade mal eine richtige Excel Beispieldatei, dann hilft dir sicher jemand. Mir fehlt der Plan und mein extra langes Wochenende hat bereits gestartet.
cu
Chris
AW: Datumfinden/Anderes auswählen
11.04.2020 10:32:11
Max
So Guten Tag,
Heute einmal mit Beispieldatei
https://www.herber.de/bbs/user/136629.zip
und hier noch der Code:
Dim A As Double 'Datumfinden und in B:C Kopieren
Dim B As Double
Dim A_1 As Variant
Dim B_1 As Variant
A_1 = CDbl(Range("G7"))
B_1 = CDbl(Range("G8"))
On Error Resume Next
'Suchfunktion für A funktioniert nur wenn Datum aus G7 vorhanden
'Sortierung ist natürlich falsch (aufsteigend nicht absteigend)
If Not IsError(Application.Match(A_1, Range("A:A"), 0)) Then
A = Application.Match(A_1, Range("A:A"), 0)
Else
A = Application.Match(A_1, Range("A:A"), -1)
End If
'Suchfunktion Für B Funktioniert ohne Probleme
If Not IsError(Application.Match(B_1, Range("A:A"), 0)) Then
B = Application.Match(B_1, Range("A:A"), 0)
Else
B = Application.Match(B_1, Range("A:A"), 1)
End If
Range(Cells(A, 1), Cells(B, 2)).Copy
Range("D9").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("I7").Value = A_1
Range("I8").Value = B_1
Wobei hier wie beschrieben wegen der Sortierung die Match-Funktion bei A ja nicht Funktioniert.
Frohe Ostern an alle
Anzeige
AW: Datumfinden/Anderes auswählen
12.04.2020 08:54:44
hary
Moin Max
Probier mal. 
Dim A As Double, B As Double
Dim A_1 As Variant, B_1 As Variant
Dim Bereich As Range
Set Bereich = Range("A9:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Application.CountBlank(Bereich) Then '--wenn im Bereich Leerzellen vorhanden
With Bereich.SpecialCells(xlCellTypeBlanks) '--nur Leerzellen benutzen
.FormulaR1C1 = "=R[-1]C+1" '--Formel eintragen
.Value = .Value '--Wert gegen Formel eintragen
End With
End If
A_1 = CDbl(Range("G7"))
B_1 = CDbl(Range("G8"))
If Not IsError(Application.Match(A_1, Bereich, 0)) Then
A = Application.Match(A_1, Bereich, 0)
End If
If Not IsError(Application.Match(B_1, Bereich, 0)) Then
B = Application.Match(B_1, Bereich, 0)
End If
If A

gruss hary
Anzeige
AW: Datumfinden/Anderes auswählen
12.04.2020 11:48:39
Max
Erst mal Frohe Ostern und danke Hary,
ich hab jetzt selber auch eine Lösung ist vllt ein bischen umständlicher aber klappt. 
Dim A As Long
Dim B As Long
Dim A_1 As Variant
Dim B_1 As Variant
Dim La As Long
Dim Lb As Long
Dim LetzteZeile As Long
'Letztegefüllte Zeile ermitteln in A:A,B:B
La = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Lb = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
If La >= Lb Then
LetzteZeile = La
Else
LetzteZeile = Lb
End If
Range(Cells(9, 1), Cells(LetzteZeile, 1)).Copy
Range("D9").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Sortierung absteigend für Match A
Range("E9").Value = 1
Range(Cells(9, 5), Cells(9, 5)).Select
Selection.AutoFill Destination:=Range(Cells(9, 5), Cells(LetzteZeile, 5)), Type:= _
xlFillSeries
Range(Cells(9, 4), Cells(LetzteZeile, 5)).Select
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Add2 Key:=Range( _
Cells(9, 5), Cells(LetzteZeile, 5)), SortOn:=xlSortOnValues, Order:=xlDescending,  _
DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Auswertung").Sort
.SetRange Range(Cells(9, 4), Cells(LetzteZeile, 5))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
A_1 = CDbl(Range("G7"))
B_1 = CDbl(Range("G8"))
On Error Resume Next
If Not IsError(Application.Match(A_1, Range("D:D"), 0)) Then
A = Application.Match(A_1, Range("D:D"), 0)
Else
A = Application.Match(A_1, Range("D:D"), -1)
End If
If Not IsError(Application.Match(B_1, Range("A:A"), 0)) Then
B = Application.Match(B_1, Range("A:A"), 0)
Else
B = Application.Match(B_1, Range("A:A"), 1)
End If
'A Anpassen
A = LetzteZeile - A + 9
ActiveWorkbook.Worksheets("Auswertung").Range(Cells(9, 4), Cells(LetzteZeile, 5)). _
ClearContents
Range(Cells(A, 1), Cells(B, 2)).Copy
Range("D9").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("I7").Value = A_1
Range("I8").Value = B_1

Anzeige
AW: Datumfinden/Anderes auswählen
12.04.2020 11:54:23
hary
Moin
Hat mein Code auch das gewuenschte Ergebniss gebracht?
Ist nur zur Info.
gruss hary
AW: Datumfinden/Anderes auswählen
13.04.2020 11:25:25
Max
So nochmal Guten Tag,
Leider nicht Hary.
Das Problem ist bei dir werden die Lücken im Bereich aufgefüllt, was bei der Späteren Auswertung zu verfälschten Ergebnissen führen würde.( Mein Fehler konntet du ja nicht wissen)
Desweiteren wird die Sortierung bei dir ja auch nicht für Application.Match geändert.
Trotzdem Vielen Dank für deine Mühe
Ich konnte nun auch das OnError ResumeNext entfernen indem ich die Variablen A_1=CDate(Range...
und B_1=Cdate(Range.... verwendet habe.
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige