Problem bei einer Abfrage

Forumthread: Problem bei einer Abfrage

16.04.2017 12:33:38

Hans-Jörg

Hallo Zusammen,
vieleicht kann mir jemand helfen, ich hab momentan keine Idee wie ich das Problem lösen kann.
Ich habe in einem Tabellenblatt,in Spalte A eine Nummer die sich eventuell öfters wiederholt (max.4x), in Spalte B sind hierzu verschiedene Datums-Angaben, in dem Tabellenblatt werden jeden Monat neue Daten hinzugefügt
Nun möchte ich, in einen neuen Tabellenblatt die Nummer aus Spalte A eintragen und in den Spalten daneben, also B/C/D/E sollen die Datums-Angaben die er auf dem ersten Tabellenblatt gefunden hat, ausgeben werden. Wenn nichts gefunden wurde soll die Spalte leer bleiben.
Danke im Voraus für Eure Hilfe
Jörg
https://www.herber.de/bbs/user/112904.zip

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Problem bei einer Abfrage

16.04.2017 16:16:55

onur
AW: Problem bei einer Abfrage

17.04.2017 10:19:17

Hans
AW: Problem bei einer Abfrage

16.04.2017 16:35:33

Sepp
AW: Problem bei einer Abfrage

16.04.2017 19:58:51

Peter
AW: Problem bei einer Abfrage

16.04.2017 22:14:15

Peter
AW: Problem bei einer Abfrage

16.04.2017 22:28:33

Peter

AW: Problem bei einer Abfrage

16.04.2017 16:16:55

onur

Mal auf die Schnelle:
https://www.herber.de/bbs/user/112908.xlsm
reicht bis 1000 zeilen - ggf ändern.

AW: Problem bei einer Abfrage

17.04.2017 10:19:17

Hans

Hallo Zusammen,
viele Dank für die schnelle Hilfe, werde es morgen ausprobieren und dann bericheten.
Noch schöne Ostertage
Gruß Jörg

AW: Problem bei einer Abfrage

16.04.2017 16:35:33

Sepp

Hallo Hans-Jörg,
Formel nach Rechts und Unten durch Ziehen ausfüllen.
Ausgabe

	A	B	C	D	E
1	Nachweis Nr	Datum	Datum 1	Datum 2	Datum 3
2	8617057	11.01.2016	18.03.2017
3	8628290	09.12.2016
4	8628291	09.12.2016
5	8628292	09.12.2016
6	8628293	12.12.2016
7	8628294	09.12.2016
8	8628295	12.12.2016
9	8628296	09.12.2016
10	8628297	12.12.2016
11	8628298	09.12.2016
12	8628299	09.12.2016
13	8628300	12.12.2016
14	8628301	09.12.2016
15	8628302	12.12.2016	15.01.2017	18.03.2017	12.04.2017
16	8628303	12.12.2016
17	8628304	09.12.2016
18	8628305	09.12.2016
19	8628306	09.12.2016
20	8628307	08.02.2017
21	8628308	09.12.2016
22	8628309	09.12.2016	27.02.2017

Formeln der Tabelle

Zelle	Formel
B2	{=WENNFEHLER(KKLEINSTE(WENN(Matrix!$A$2:$A$1000=$A2;Matrix!$B$2:$B$1000); SPALTE(A1)); "")}

Enthält Matrixformel:
Umrandende { } nicht miteingeben,
sondern Formel mit STRG+SHIFT+RETURN abschließen!

Matrix verstehen

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

Gruß Sepp

AW: Problem bei einer Abfrage

16.04.2017 19:58:51

Peter

Hallo Hans-Jörg,
so könnte es ebenfalls funtionieren Option Explicit Public Sub Find_Methode() Dim MyDict As Object Dim WkSh_Q As Worksheet Dim WkSh_Z As Worksheet Dim lZeile_Q As Long Dim lZeile_Z As Long Dim rZelle As Range Dim sFundst As String Dim iSpalte As Integer Set MyDict = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Set WkSh_Q = ThisWorkbook.Worksheets("Matrix") Set WkSh_Z = ThisWorkbook.Worksheets("Ausgabe") With WkSh_Z .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents lZeile_Z = 1 End With With WkSh_Q.Columns(1) For lZeile_Q = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row If Not MyDict.exists(.Range("A" & lZeile_Q).Value) Then MyDict(Trim$(.Range("A" & lZeile_Q).Value)) = MyDict(Trim$(.Range("A" & lZeile_Q). _ Value)) Set rZelle = .Find(What:=.Range("A" & lZeile_Q).Value, LookAt:=xlWhole, LookIn:= _ xlValues) If Not rZelle Is Nothing Then sFundst = rZelle.Address lZeile_Z = lZeile_Z + 1 WkSh_Z.Range("A" & lZeile_Z).Value = WkSh_Q.Range("A" & lZeile_Q).Value iSpalte = 2 Do WkSh_Z.Cells(lZeile_Z, iSpalte).Value = WkSh_Q.Range("B" & rZelle.Row).Value iSpalte = iSpalte + 1 Set rZelle = .Cells.FindNext(rZelle) Loop While Not rZelle Is Nothing And rZelle.Address sFundst 'Else ' MsgBox "Der gesuchte Begriff """ & .Range("A" & lZeile).Value & """ wurde _ nicht gefunden.", _ 48, " Hinweis für " & Application.UserName End If End If Next lZeile_Q End With Application.ScreenUpdating = True Set MyDict = Nothing Set WkSh_Q = Nothing Set WkSh_Z = Nothing End Sub Gruß Peter

AW: Problem bei einer Abfrage

16.04.2017 22:14:15

Peter

Hallo Hans-Jörg,
vergiss bitte meine erste Lösung und nimm diese dafür, sie sollte besser passen.

Option Explicit
Public Sub Find_Methode()
Dim MyDict    As Object
Dim WkSh_Q    As Worksheet
Dim WkSh_Z    As Worksheet
Dim lZeile_Q  As Long
Dim lZeile_Z  As Long
Dim rZelle    As Range
Dim sFundst   As String
Dim iSpalte   As Integer
Set MyDict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set WkSh_Q = ThisWorkbook.Worksheets("Matrix")
Set WkSh_Z = ThisWorkbook.Worksheets("Ausgabe")
With WkSh_Z
.Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
lZeile_Z = 1
End With
For lZeile_Q = 2 To WkSh_Q.Cells(Rows.Count, 1).End(xlUp).Row
If Not MyDict.exists(Trim$(WkSh_Q.Range("A" & lZeile_Q).Value)) Then
MyDict(Trim$(WkSh_Q.Range("A" & lZeile_Q).Value)) = 0
GoSub Datum_uebergeben
End If
Next lZeile_Q
Application.ScreenUpdating = True
Set MyDict = Nothing
Set WkSh_Q = Nothing
Set WkSh_Z = Nothing
Exit Sub
Datum_uebergeben:
With WkSh_Q.Columns(1)
Set rZelle = .Find(What:=WkSh_Q.Range("A" & lZeile_Q).Value, LookAt:=xlWhole, LookIn:= _
xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
lZeile_Z = lZeile_Z + 1
WkSh_Z.Range("A" & lZeile_Z).Value = WkSh_Q.Range("A" & lZeile_Q).Value
iSpalte = 2
Do
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = WkSh_Q.Range("B" & rZelle.Row).Value
iSpalte = iSpalte + 1
Set rZelle = .Cells.FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
'Else
'  MsgBox "Der gesuchte Begriff  """ & .Range("A" & lZeile).Value & """  wurde nicht  _
gefunden.", _
48, "   Hinweis für " & Application.UserName
End If
End With
Return
End Sub

Gruß Peter

AW: Problem bei einer Abfrage

16.04.2017 22:28:33

Peter

Hallo Hans-Jörg,
offensichtlich sind doch aller guten Dinge drei und du solltest diese Version als die gültige ansehen

Option Explicit
Public Sub Find_Methode()
Dim MyDict    As Object
Dim WkSh_Q    As Worksheet
Dim WkSh_Z    As Worksheet
Dim lZeile_Q  As Long
Dim lZeile_Z  As Long
Dim rZelle    As Range
Dim sFundst   As String
Dim iSpalte   As Integer
Set MyDict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set WkSh_Q = ThisWorkbook.Worksheets("Matrix")
Set WkSh_Z = ThisWorkbook.Worksheets("Ausgabe")
With WkSh_Z
.Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
End With
lZeile_Z = 1
For lZeile_Q = 2 To WkSh_Q.Cells(Rows.Count, 1).End(xlUp).Row
If Not MyDict.exists(Trim$(WkSh_Q.Range("A" & lZeile_Q).Value)) Then
MyDict(Trim$(WkSh_Q.Range("A" & lZeile_Q).Value)) = 0
With WkSh_Q.Columns(1)
Set rZelle = .Find(What:=.Range("A" & lZeile_Q).Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
lZeile_Z = lZeile_Z + 1
WkSh_Z.Range("A" & lZeile_Z).Value = WkSh_Q.Range("A" & lZeile_Q).Value
iSpalte = 2
Do
WkSh_Z.Cells(lZeile_Z, iSpalte).Value = WkSh_Q.Range("B" & rZelle.Row).Value
iSpalte = iSpalte + 1
'Set rZelle = .FindNext(rZelle)
Set rZelle = .Cells.FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
'Else
'  MsgBox "Der gesuchte Begriff  """ & .Range("A" & lZeile).Value & """  wurde nicht  _
gefunden.", _
48, "   Hinweis für " & Application.UserName
End If
End With
End If
Next lZeile_Q
Application.ScreenUpdating = True
Set MyDict = Nothing
Set WkSh_Q = Nothing
Set WkSh_Z = Nothing
End Sub

Gruß Peter

Beliebteste Forumthreads (12 Monate)

Forumthread: Problem bei einer Abfrage

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread