Zeilen kopieren, wenn ..

Forumthread: Zeilen kopieren, wenn ..

Anna

Hallo Excel-Profis,
ich fand im Archiv nichts passendes, was meinen Wunsch abdeckt.
Von einem Fremdsystem habe ich die Tabelle1 in der ca 500 Datensätze sind. (500 Zeilen).
In der Spalte D (4. Spalte) steckt eine Zahl oder ein Begriff ( z.B. 1250 oder BA17, oder 0001 etc.).
Excel soll nun von jeder Sorte ( Spalte D) je einen Datensatz in Tabelle2 übertragen, so dass aber in Tabelle2 nur jeweils die erste gefundene Zeile kopieren, so dass in Tabelle2 in Spalte D keine doppelten Sätze existieren.
Wichtig:
in Tabelle 1 und in Tabelle 2 sind die ersten 4 Zeilen, Titel, Datum, etc..
Diese Zeilen also von diesem Kopiermechanismus ausschliessen.
Zusatz (nur wenn so etwas geht) - "Nice to have":
in der Tabelle1 sind maximum 30 Spalten belegt (AD).
es wäre natürlich super, wenn in der Spalte AE in Tabelle 2 stehen würde, aus welcher Zeile (aus Tabelle1) der Datensatz stamm.
z.B. in Tabelle2, AD17: "10" (=10. Zeile, Tabelle1).
Danke für einen kleinen Code.
Anna

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Zeilen kopieren, wenn ..

15.11.2011 14:14:26

Rudi

Hallo,
das sollte es bringen:

Sub kopieren()
Dim lRow As Long, rngCopy As Range, oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
With Sheets("Tabelle1")
For lRow = 5 To Cells(Rows.Count, 4).End(xlUp).Row
If Not oDict.exists(.Cells(lRow, 4).Value) Then
oDict(.Cells(lRow, 4).Value) = lRow
If rngCopy Is Nothing Then
Set rngCopy = .Cells(lRow, 1)
Else
Set rngCopy = Union(rngCopy, .Cells(lRow, 1))
End If
End If
Next
End With
If Not rngCopy Is Nothing Then
rngCopy.EntireRow.Copy Sheets(2).Cells(1, 1)
With Sheets(2)
For lRow = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
.Cells(lRow, 31) = oDict(.Cells(lRow, 4).Value)
Next lRow
End With
End If
End Sub

Gruß
Rudi

AW: Zeilen kopieren, wenn ..

15.11.2011 15:12:59

Anna

Hallo Rudi,
leider kann ich wirklich kein VBA.
Bereits bin ich aber angemeldet, und ich will mich nach dem Kursus auch damit beschäftigen.
Der kleine Fehler in meinem Text oder in Deinem Code liegt noch dort, dass in der Tabelle2 auf der Zeile1 mit dem Schreiben begonnen wird, statt auch auf Zeile 5.
Danke
Anna

AW: Zeilen kopieren, wenn ..

15.11.2011 15:13:15

Anna

AW: Zeilen kopieren, wenn ..

15.11.2011 16:21:24

Rudi

Hallo,
dann so:

Sub kopieren()
Dim lRow As Long, rngCopy As Range, oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
With Sheets("Tabelle1")
For lRow = 5 To Cells(Rows.Count, 4).End(xlUp).Row
If Not oDict.exists(.Cells(lRow, 4).Value) Then
oDict(.Cells(lRow, 4).Value) = lRow
If rngCopy Is Nothing Then
Set rngCopy = .Cells(lRow, 1)
Else
Set rngCopy = Union(rngCopy, .Cells(lRow, 1))
End If
End If
Next
End With
If Not rngCopy Is Nothing Then
rngCopy.EntireRow.Copy Sheets(2).Cells(5, 1)
With Sheets(2)
For lRow = 5 To .Cells(Rows.Count, 4).End(xlUp).Row
.Cells(lRow, 31) = oDict(.Cells(lRow, 4).Value)
Next lRow
End With
End If
End Sub

Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

Forumthread: Zeilen kopieren, wenn ..

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread