Problem bei einer Abfrage

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

Beliebteste Forumthreads (12 Monate)

	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

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread