Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1588to1592
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

VBA: Problem Vergleichen und Kopieren

VBA: Problem Vergleichen und Kopieren
07.11.2017 10:03:01
Schmitt
Hallo ich benötige eure Unterstützung.
Mein Problem:
Ich habe zwei Tabellen.
In Tabelle 1 steht in Spalte N (14) ab Zeile 6 bis zum ende der Spalte Nummern, die Nummern wiederholen sich und stehen für ein Attributesets(genau diese stehen in Tabelle 2) der jeweiligen Zeile.
In der Tabelle 2 stehen die gewünschten Attributesets, in Spalte A ab Zeile 5 bis 800 stehen chronologisch die Nummerncodes und in selbiger Zeile von Spalte G bis AA die Attributesets (immer gleich "breit")
Ich möchte nun die Werte in Tabelle 1 in Spalte N mit denen in Tabelle 2 spalte A vergleichen und dann das ganze Attributeset, also G bis AA von der Zeile des Treffers in Tabelle 2 in die Zeile kopieren in Tabelle 1, ab Spalte V Zeile in der gerade die Schleife den Vergleichswert holt .
Formel lösung mit index benutze ich gerade, Problem ich möchte Listen in Attributesets nutzen und bevorzuge die makro Methode,  da es viele Formeln sind und die Performance leidet.
Hoffe ihr könnt mir helfen.
VG

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

Betreff
Datum
Anwender
Anzeige
AW: VBA: Problem Vergleichen und Kopieren
07.11.2017 10:17:01
Michael
Hallo!
So?
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle2")
Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tabelle1")
Dim r As Range, f As Range, c As Range
Application.ScreenUpdating = False
With WsZ
For Each c In .Range("N6:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
With WsQ
Set r = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Set f = r.Find(what:=c, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
f.Offset(, 6).Resize(1, 21).Copy _
WsZ.Cells(c.Row, "V")
End If
End With
Next c
End With
Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Set r = Nothing: Set f = Nothing: Set c = Nothing
End Sub
LG
Michael
Anzeige
AW: VBA: Problem Vergleichen und Kopieren
07.11.2017 11:54:36
Schmitt
Ja so geht dass, vielen dank!
Jetzt versuche ich noch eine Abfrage einzubauen , damit bereitskopierte Attributeset nicht nochmal berücksichtig werden. Also dachte ich mir ich hänge an meine Attributesets eine spalte mit "x" und versuche nun eine Abfrage zu bauen mit if spalte xy="x" next else dein makro, mal sehen ob ich es hinbekomme.
Grüße
Schmitt
Viel Erfolg, Danke für die Rückmeldung, owT
07.11.2017 12:37:48
Michael
AW: Viel Erfolg, Danke für die Rückmeldung, owT
07.11.2017 13:47:38
Schmitt
Hmm bekomme es nicht hin kannst du mir evwntuell nochmal aus helfen?
Also er kopiert mit jetzt mit den attributen in spalte CW das x nun soll quasi beim erneuten durchlaufen des makros überprüft werden, ob in Spalte CW ein x steht , wenn ja dann nicht kopieren ansonten Nummerncode prüfen und Attribiteset kopieren.
Anzeige
Meinst Du so...
07.11.2017 14:02:36
Michael

Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle2")
Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tabelle1")
Dim r As Range, f As Range, c As Range
Application.ScreenUpdating = False
With WsZ
For Each c In .Range("N6:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
With WsQ
Set r = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Set f = r.Find(what:=c, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
If f.Offset(, 100)  "x" Then
f.Offset(, 6).Resize(1, 21).Copy _
WsZ.Cells(c.Row, "V")
f.Offset(, 100) = "x"
End If
End If
End With
Next c
End With
Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Set r = Nothing: Set f = Nothing: Set c = Nothing
End Sub
In diesem Fall wird nicht kopiert, wenn in Spalte "CW" (auf dem Quellblatt) ein "x" vorhanden ist, wenn kopiert wird, wird gleichzeitig ein "x" in die Spalte "CW" des Datensatzes geschrieben (auf dem Quellblatt).
LG
Michael
Anzeige
AW: Meinst Du so...
07.11.2017 15:29:45
Schmitt

Sub Kopieren()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle2")
Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tabelle1")
Dim r As Range, f As Range, c As Range
Application.ScreenUpdating = False
With WsZ
For Each c In .Range("N6:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
With WsQ
Set r = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
Set f = r.Find(what:=c, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
If WsZ.Cells(c.Row, 101)  "" Then
f.Offset(, 6).Resize(1, 67).Copy _
WsZ.Cells(c.Row, "AI")
End If
End If
End With
Next c
End With
Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Set r = Nothing: Set f = Nothing: Set c = Nothing
End Sub
so heeum wollte ich es haben, danke für die Hilfestellung, nur damit konnte ich es umbauen.
vielen Dank nochmal!
VG
Schmitt
Anzeige
AW: Meinst Du so...
07.11.2017 15:38:37
Schmitt
hier steht natürlich was anderes habe das "x" vergessen.
If WsZ.Cells(c.Row, 101)  "x" Then
mit der Zeile macht das Makro was ich will ^^.
VG
Na dann, gern, viel Erfolg noch owT
07.11.2017 16:01:38
Michael

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige