Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1604to1608
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
Inhaltsverzeichnis

Vergleichliste mit Mehrfachauswahl

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
Anzeige
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

Anzeige
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
Anzeige
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

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige