Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: Wert in Tabelle 2 suchen und Fundstellen übertrage

Wert in Tabelle 2 suchen und Fundstellen übertrage
26.10.2012 09:44:21
casantis
Hallo liebe Gemeinde,
Ich habe dieses Macro hier im Forum gefunden. Dabe werden die Werte aus Spalte A der Tabelle1 in Tabelle2 an beliebiger Stelle gesucht und die Werte aus den Spalten B:C der Fundzeile in dieses Blatt übernommen werden.
Sub Uebetragen()
Dim rng As Range
Dim iRowL As Integer, iRow As Integer
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iRowL
If Not IsEmpty(Cells(iRow, 1)) Then
With Worksheets("Tabelle2")
Set rng = .Cells.Find(Cells(iRow, 1), _
lookat:=xlPart, LookIn:=xlValues)
If Not rng Is Nothing Then
Cells(iRow, 2) = .Cells(rng.Row, 2)
Cells(iRow, 3) = .Cells(rng.Row, 3)
End If
End With
End If
Next iRow
End Sub
Wie kann mann es so erweitern:
1. nach Werten aus Spalte A der Tabelle1 in Tabelle2 an beliebiger Stelle suchen.
2. wenn den Wert gefunden wurde, dann soll der Wert der Spalte B der Tabelle1 mit dem Wert der Spalte A der Tabelle2 abgegliechen werden.
3. Wenn die Werte gleich sind, dann sollen die Werte der Zeile aus Tabelle1 in die Tabelle 2 ab der dritte leerstehenden Spalte übernommen werden.
4. Variante 1: die abgearbeitete Zeile soll in der Tabelle2 farblich markiert werden.
Variante 2: die abgearbeitete Zeile soll in der Tabelle2 gelöscht werden
vielen Dank für eure Hilfe
anbei ist die Mustertabelle:
https://www.herber.de/bbs/user/82322.xlsx

Anzeige

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Wert in Tabelle 2 suchen und Fundstellen übertrage
28.10.2012 20:08:45
fcs
Hallo Casantis,
hier ein entsprechend angepasstest Makro.
Gruß
Franz
Sub Uebetragen()
Dim wks1 As Worksheet, wks2 As Worksheet
Dim rng As Range
Dim iRowL As Integer, iRow As Integer
Set wks1 = ActiveSheet
Set wks2 = Worksheets("Tabelle2")
With wks1
iRowL = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For iRow = 1 To iRowL
If Not IsEmpty(wks1.Cells(iRow, 1)) Then
With wks2
Set rng = .Cells.Find(wks1.Cells(iRow, 1), _
lookat:=xlPart, LookIn:=xlValues)
If Not rng Is Nothing Then
If wks1.Cells(iRow, 2).Value = .Cells(rng.Row, 1) Then
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, .Columns.Count).End(xlToLeft)).Copy  _
_
Destination:=wks1.Cells(iRow, 5)
End If
'Variante 1
rng.EntireRow.Interior.ColorIndex = 3
'Variante 2
'              rng.EntireRow.clearcontents
End If
End With
End If
Next iRow
End Sub

Anzeige
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige