Anzeige
Archiv - Navigation
876to880
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
876to880
876to880
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Tabellen vergleichen und kopieren

Tabellen vergleichen und kopieren
20.06.2007 15:11:00
splash
Hallo zusammen!
Habe noch ein kleines Problem: Ich möchte zwei Tabellenblätter vergleichen, d.h. in Spalte D stehen Zahlen die verglichen werden sollen. Wenn in beiden Tabellenblätter die gleiche Zahl in Spalte D steht, soll die ganze Zeile aus Tabelle 1 und Tabelle 2 in ein weiteres Tabellenblatt kopiert werden. Außerdem sollen die Zeilen farbig unterlegt sein! Der folgende Code (von Mo/nighty! Danke dafür!!!) funktioniert auch! Allerdings gibt das Makro nur den "ersten Fund" zurück! Was könnte man ändern, wenn ALLE gleichen Werte (aus einem/beiden Tabellenblatt) in das dritte Blatt kommen sollten! Bsp: Es soll nur eine Kopie der Zeile in Tabelle3 auftauchen, wenn das Kriterium auch in beiden Tabellen vorkommt! Heißt: In Tabelle1, Spalte D steht drei mal die "12" und in Tabelle2, Spalte D keine mal "12", Ergebnis: keine Kopie in Tabelle3. In Tabelle1, Spalte D steht drei mal die "12" und in Tabelle2, Spalte D ein mal die "12", Kopie der drei Zeilen aus Tabelle1 und Kopie von der einen Zeile aus Tabelle2.
Danke für Eure Hilfe!
Splash

Sub liste_erstellen()
Dim zaehler As Long, zielzeile As Long, zeile As Long
Dim suche As Range
ReDim bereich(1, 1) As Variant
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Sheets("Tabelle2").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Rows("1:1000").Interior.Color = RGB(200, 500, 500)
Sheets("Tabelle1").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Rows("1:1000").Interior.Color = RGB(100, 500, 500)
zeile = Worksheets(2).Cells(Rows.Count, 4).End(xlUp).Row
ReDim bereich(zeile, 1)
bereich() = Range(Cells(1, 4), Cells(zeile, 4))
For zaehler = 1 To zeile
Set suche = Worksheets(2).Range("D2:D" & zeile).Find(bereich(zaehler, 1))
If Not suche Is Nothing Then
zielzeile = Worksheets(3).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets(1).Rows(zaehler & ":" & zaehler).Copy Worksheets(3).Range("A" & zielzeile)
Worksheets(2).Rows(suche.Row & ":" & suche.Row).Copy Worksheets(3).Range("A" & zielzeile + 1)
End If
Next zaehler
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Sheets("Tabelle3").Activate
Columns("A:Z").EntireColumn.AutoFit
Rows("1:56000").EntireRow.AutoFit
End 

Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellen vergleichen und kopieren
22.06.2007 19:50:00
nighty
hi all :-)
crossposter
in einem anderen forum loesung praesent
gruss nighty
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige