Vergleichliste mit Mehrfachauswahl

Forumthread: Vergleichliste mit Mehrfachauswahl

30.01.2018 10:15:02

Logi

Mahlzeit Zusammen,
ich krieg aus dem u.g. VBA-Code keine erweiterten FIND hin.
Sodass er nicht nur den ersten Eintrag findet, sondern auch weiterhin sucht bis
zum letzten gefundenen Eintrag und diesen natürlich auch in die Tabelle3 rüber kopiert.
Hättet ihr ein Tipp wie ich das hinkriege?
Hinweis,
ich habe Materialnummern mit Bezeichnungen und weiteren Informationen in Tabelle1.
In der Tabelle2 sollen Materialnummern eingefügt werden, diese dann mit den Materialnummern von Tabelle1 verglichen werden, sobald welche vorhanden sind, sollen sie in Tabelle3 kopiert werden - sprich die Zeile ab Spalte C.
Vielen Dank vorab.
Gruß,
Logi


For LoI = 1 To LoLetzte2                        ' Schleife über Kopie
If WsT2.Cells(LoI, 2)  "" Then
Set RaFound = WsT1.Range("A1:A500" & LoLetzte1).Find(WsT2.Cells(LoI, 2), _
WsT1.Range("A" & LoLetzte1), , xlWhole, , xlNext)
If Not RaFound Is Nothing Then          ' Begriff gefunden
WsT1.Rows(RaFound.Row).Copy         ' gefundene Zeile kopieren
With Worksheets("Tabelle3")
' letzte belegte Zeile in Tabelle 3 ermitteln
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
' ermittelte Zeilennummer mit max. Anzahl vergleichen
If Loletzte3 > Rows.Count Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
' Zwischenspeicher löschen
Application.CutCopyMode = False
Exit Sub
End If
' Werte übertragen
.Rows(Loletzte3).PasteSpecial paste:=xlValues
' Formate übertragen
.Rows(Loletzte3).PasteSpecial paste:=xlFormats
' Werte übertragen in die gleiche Zeile wie Tabelle1
'.Rows(RaFound.Row).PasteSpecial Paste:=xlValues
' Formate übertragen in die gleiche Zeile wie Tabelle1
'.Rows(RaFound.Row).PasteSpecial Paste:=xlFormats
End With
End If
End If

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 10:33:02

Peter(silie)
AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 10:47:25

Logi
AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 11:17:53

Logi

AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 10:33:02

Peter(silie)

Hallo,
eine mehrfach Suche könnte so aussehen:
(Du musst noch alles auf deinen Code anpassen!)

Option Explicit
Sub a()
Dim ws As Worksheet
Dim rng As Range, c As Range
Dim firstAddress As Variant
Dim searchThis As String
Set ws = ThisWorkbook.Sheets("some sheet")
With ws
searchThis = .Cells(LoI, 2).Value
Set rng = 'Deine Range
Set c = rng.Find(What:=searchThis, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'Sachen die gemacht werden sollen
Set c = rng.FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub

AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 10:47:25

Logi

Hallo Peter,
dank dir für deine Antwort.
Genau das Anpassen krieg ich nämlich nicht hin.
Ich hab hier schon einen Vorhandenen Code, der die Mehrfachsuche auch ausführt.
Nur fehlt mir das notwendige knowhow das so umzumodeln, dass es mit meinem Code funzt.

With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
If c is Nothing Then
GoTo DoneFinding
End If
Loop While Not c Is Nothing And c.Address  firstAddress
End If
DoneFinding:
End With

Danke
Gruß,
logi

AW: Vergleichliste mit Mehrfachauswahl

30.01.2018 11:17:53

Logi

Oke ich hab es !!
Danke trotzdem !!


For LoI = 1 To LoLetzte2                        ' Schleife über Kopie
If WsT2.Cells(LoI, 2)  "" Then
Set RaFound = WsT1.Range("A1:A" & LoLetzte1).Find(WsT2.Cells(LoI, 2), _
WsT1.Range("A" & LoLetzte1), , xlWhole, , xlNext)
If Not RaFound Is Nothing Then          ' Begriff gefunden
firstAddress = RaFound.Address
Do
WsT1.Rows(RaFound.Row).Copy         ' gefundene Zeile kopieren
With Worksheets("Tabelle3")
' letzte belegte Zeile in Tabelle 3 ermitteln
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
' ermittelte Zeilennummer mit max. Anzahl vergleichen
If Loletzte3 > Rows.Count Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
' Zwischenspeicher löschen
Application.CutCopyMode = False
Exit Sub
End If
' Werte übertragen
.Rows(Loletzte3).PasteSpecial paste:=xlValues
' Formate übertragen
.Rows(Loletzte3).PasteSpecial paste:=xlFormats
' Werte übertragen in die gleiche Zeile wie Tabelle1
'.Rows(RaFound.Row).PasteSpecial Paste:=xlValues
' Formate übertragen in die gleiche Zeile wie Tabelle1
'.Rows(RaFound.Row).PasteSpecial Paste:=xlFormats
End With
Set RaFound = WsT1.Range("A1:A" & LoLetzte1).FindNext(RaFound)
Loop While Not RaFound Is Nothing And RaFound.Address  firstAddress
End If
End If

Beliebteste Forumthreads (12 Monate)

Vergleichliste mit Mehrfachauswahl

Forumthread: Vergleichliste mit Mehrfachauswahl

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread