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

kopieren der jeweils ersten Zeile zu einer ID

kopieren der jeweils ersten Zeile zu einer ID
20.06.2004 16:19:46
JanetT
Hallo,
ich habe in einer Tabelle folgendes Redundanz Problem. Ich habe zu jeder ID mehrere Zeilen benoetige aber nur die jeweils erste Zeile zu der jeweiligen ID.
Userbild
Gibt es eine moeglichkeit immer nur diese erste Zeile (die gelben im Screenshot zu kopieren)
Vielen Dank, ich komme da leider ueberhaupt nicht weiter.
JanetT

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: kopieren der jeweils ersten Zeile zu einer ID
K.Rola
Hallo,
schon, wohin soll kopiert werden?
Gruß K.Rola
AW: kopieren der jeweils ersten Zeile zu einer ID
NE
Hi Janet,
meinst Du in etwa sowas, die ganze Zeile aus Tabelle1 wird in Tabelle2 kopiert

Sub x()
Dim i&, x&, y&
With Sheets("Tabelle1")
i = .Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To i
y = x
While .Cells(y, 1) = .Cells(x, 1)
If y > i Then Exit Sub
y = y + 1
Wend
.Cells(x, 1).EntireRow.Copy _
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
x = y
Next
End With
End Sub

Gruss Nancy
AW: kopieren der jeweils ersten Zeile zu einer ID
20.06.2004 17:40:35
JanetT
Vielen Dank euch beiden, es funktioniert fast. Ich verstehe nur nicht warum das Macro nicht immer die erste Zeile nimmt. Ich brauch nämlich immer genau die erst Zeile. Ich versteh aber leider dies komplizierte Schleife ueberhaupt nicht.
Userbild
Gruss Janet
Anzeige
AW: kopieren der jeweils ersten Zeile zu einer ID
NE
Hi Janet,
silly me, kleiner Lapsus ...
Hab vergessen mit x=y-1 wieder um 1 zurückzusetzen,
so sollte es besser gehen [hoffentlich]
Gruss Nancy
--

Sub x()
Dim i&, x&, y&
With Sheets("Tabelle1")
i = .Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To i
y = x
While .Cells(y, 1) = .Cells(x, 1)
If y > i Then Exit Sub
y = y + 1
Wend
.Rows(x).Copy Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
x = y - 1
Next
End With
End 

Sub

AW: kopieren der jeweils ersten Zeile zu einer ID
Reinhard
Hi janeT,

Sub test()
Dim i&, x&, y&
With Sheets("Tabelle1")
For n = 2 To .Range("A65536").End(xlUp).Row
If .Cells(n, 1) <> .Cells(n - 1, 1) Then
.Rows(n).Copy Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next n
End With
End Sub

Gruß
Reinhard
Anzeige
Hehe
NE
Hi Reinhard,
Mensch, das ist doch viel zu einfach !!! ;;-)))
lg Nancy
--
Make it as simple as possible - but not simpler.
Vielen Dank ,Super!
20.06.2004 19:43:54
JanetT
Vielen Dank, funktioniert super.
JanetT
AW: Hehe
Reinhard
sorry Nancy, das hatte ich so nicht bedacht *schäm*, hier nun die neue Version, ich hoffe sie entspricht den Regeln besser *grien*
Lieben Gruß
Reinhard

Sub test2()
With Sheets("Tabelle1")
Sheets("Tabelle1").Activate
.Range(Cells(2, 1), Cells(.Range("A65536").End(xlUp).Row, 2)).Copy _
Destination:=Worksheets("Tabelle2").Cells(1, 1)
End With
With Sheets("Tabelle2")
Sheets("Tabelle2").Activate
.Range("C1").FormulaR1C1 = "1"
.Range("C2").FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],0,1)"
.Range("C2").Copy
ActiveSheet.Paste Destination:=.Range("C2:C" & .Range("A65536").End(xlUp).Row)
Application.CutCopyMode = False
.Range("C1:C" & .Range("A65536").End(xlUp).Row).Copy
.Range("C1:C7").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("A1:C" & .Range("A65536").End(xlUp).Row).Sort _
Key1:=Range("C1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.CutCopyMode = False
For n = .Range("c65536").End(xlUp).Row To 1 Step -1
If .Cells(n, 3) = 0 Then Rows(n).Delete
Next n
Columns(3).Clear
End With
End Sub

Anzeige
OT AW: Hehe
NE
Hallo Reinhard,
zum Teufel aber auch, das muss doch noch anders gehen,
ich hab mal noch ein Option Explicit reingenommen,
mich aber jetz grad sowas von verheddert ...
Nächtle & Gruss ;-)
Nancy
--
'möge man uns diese Albernheiten nachsehen

Sub groberUnfug()
Dim x&, y&, z&
If ActiveSheet.Name <> "Tabelle1" Then
MsgBox "falsche Starttabelle, check your pole-position"
Exit Sub
ElseIf ActiveSheet.Next.Name <> "Tabelle2" Then
MsgBox "falsche Tabellenkonstellation, bitte organisieren Sie Ihre Mappe neu"
Exit Sub
End If
For x = 2 To Range("A65536").End(xlUp).Row
If Cells(x, 1) <> Cells(x - 1, 1) Then
ReDim bla(1 To Cells(x, 256).End(xlToLeft).Column)
For y = 1 To Cells(x, 256).End(xlToLeft).Column
bla(y) = Cells(x, y).Value
Next
With ActiveSheet.Next
.Range(.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0), _
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row, UBound(bla)) = Application.Transpose(bla)
End With
End If
Next
End 

Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige