Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
184to188
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
184to188
184to188
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

gleiche zellen nebeneinander setzen

gleiche zellen nebeneinander setzen
22.11.2002 09:27:59
Marcel
Hallo, folgendes Problem:
Tabelle mit 2 Spalten, 1. AFNR (Aufnahmenummer),2.Procedur.
es sind ca.25000 Zeilen. Es ist nun so, daß unter AFNR eine Nummer mehrfach vorkommt, aber die zugörige Procedur eine andere ist. Ich möchte nun, daß es für jede AFNR nur noch einen Datensatz gibt und die verschiedenen Proceduren nebeneinander in neuen Spalten stehen. Ich hoffe das war verständlich. ein kurzes bsp.
AFNR | Proc
1 | 300.s
1 | 350.m
1 | 345.e
2 | 400.d
2 | 345.e
3 | 345.f
usw.
das ziel ist dann: AFNR | Proc1 | Proc2 | Proc3...
1 | 300.s | 350.m | 345.e
usw.
Marcel

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: gleiche zellen nebeneinander setzen
22.11.2002 09:52:02
Ralf Sögel
sind die AFNR sortiert? Wenn nicht, dürfen sie sortiert werden?
Re: gleiche zellen nebeneinander setzen
22.11.2002 09:56:59
Marcel
ja, die sind sortiert, bzw. dürfen sortiert werden.
Re: gleiche zellen nebeneinander setzen
22.11.2002 10:30:11
Knud
Hi,
um bei Ralfs Ansatz weiterzumachen (ohne zu wissen, wo er hin wollte), wie wäre es mit transponieren? Bei vielen AFNR ist das natürlich eine elende händische Arbeit. Aber es müsste nicht alles noch mal getippt werden.

...Knud

Re: gleiche zellen nebeneinander setzen
22.11.2002 10:46:50
Marcel
bei 25000 Datensätzen??? nicht wirklich,oder?
Re: gleiche zellen nebeneinander setzen
22.11.2002 10:57:32
Knud
Wirklich entscheidend ist dabei ja nicht die Anzahl der Datensätze, sondern die der AFNR. Aber Du hast recht... bei den Datenmengen ist das vmtl. nicht praktikabel. Vielleicht kann ja einer der VBA-Cracks den Ansatz automatisieren?

Knud

Anzeige
Re: gleiche zellen nebeneinander setzen
22.11.2002 12:22:32
Ralf Sögel
Bei 25.000 Datensätzen solltest du etwas Geduld haben:

Option Explicit
''Die Daten beginnen in Zelle A1, der Suchbegriff(AFNR) muss
''eine Ganzzahl sein, ansonsten die Variable SB als Variant oder
''als String deklarieren!
''Der Code sollte nur einmalig ausgeführt werden, da ich auf
''eine Überprüfung verzichtet habe.
Sub zusammenfassen()
Dim SB As Long ''Suchbegriff ggf. als Variant oder String deklarieren!
Dim WSH As Worksheet, LZ As Long, Z As Long, ZZ As Long
Dim X As Long, S As Integer, NZ As Long
''Tabellenname ggf. anpassen!
Set WSH = ThisWorkbook.Sheets("Tabelle1")
LZ = WSH.[a65536].End(xlUp).Row
If LZ = 1 Then Exit Sub
ZZ = 1
S = 3
X = 1
NZ = 1
''Code beschleunigen
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

''Erstmal sortieren, falls noch nicht sortiert ist.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For Z = 1 To LZ
ZZ = ZZ + 1
''SB muss Ganzzahl sein oder siehe weiter oben!
SB = Cells(ZZ, 1).Value
While Cells(ZZ, 1).Value = SB And X < LZ
WSH.Cells(NZ, S) = WSH.Cells(ZZ, 2)
WSH.Rows(ZZ).ClearContents
''Falls die max. Anzahl der Spalten überschritten wird!
If S <= 256 Then
S = S + 1
Else
MsgBox "Maximum von 256 Spalten erreicht!" & Space(10), 64, "weise hin..."
Set WSH = Nothing
Exit Sub
End If
ZZ = ZZ + 1
X = X + 1
Wend
S = 3
NZ = Z + X
If ZZ >= LZ Then Exit For
Next

''Sortieren, um Leerzeilen zu entfernen.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With

''Objektvariable löschen
Set WSH = Nothing

End Sub

Anzeige
Re: gleiche zellen nebeneinander setzen
22.11.2002 13:13:15
Marcel
Genial.Läuft super. Hat alles Funktioniert. Vielen Dank.
zu früh gefreut
22.11.2002 13:29:26
Marcel
Leider nur fast genial. er löscht alle raus, die nur einmal da sind (sowas gibts auch) und setzt deren Procedur an die stelle des vorhergehenden.
Re: zu früh gefreut
22.11.2002 15:40:23
Ralf Sögel
Werds mir nochmal ansehen, schau mal abends(nach 20:00 Uhr) in diesen Thread.
Jetzt aber...
22.11.2002 17:29:31
Ralf Sögel
Option Explicit
''Die Daten beginnen in Zelle A1, der Suchbegriff(AFNR) muss
''eine Ganzzahl sein, ansonsten die Variable SB als Variant oder
''als String deklarieren!
Sub zusammenfassen()
Dim SB As Long ''Suchbegriff ggf. als Variant oder String deklarieren!
Dim WSH As Worksheet, LZ As Long, Z As Long, ZZ As Long
Dim X As Long, S As Integer, NZ As Long
''Tabellenname ggf. anpassen!
Set WSH = ThisWorkbook.Sheets("Tabelle1")
LZ = WSH.[a65536].End(xlUp).Row
If LZ = 1 Then Exit Sub
ZZ = 1
S = 3
X = 1
NZ = 1
''Code beschleunigen
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

''Erstmal sortieren, falls noch nicht sortiert ist.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For Z = 1 To LZ
''SB muss Ganzzahl sein oder siehe weiter oben!
SB = Cells(ZZ, 1).Value
While WSH.Cells(ZZ, 1).Value = SB And X < LZ
If WSH.Cells(ZZ + 1, 1) = SB Then
WSH.Cells(NZ, S) = WSH.Cells(ZZ, 2)
WSH.Cells(ZZ + 1, 1).Interior.ColorIndex = 19
X = X + 1
End If
''Falls die max. Anzahl der Spalten überschritten wird!
If S <= 255 Then
S = S + 1
Else
MsgBox "Maximum von 256 Spalten erreicht!" & Space(10), 64, "weise hin..."
Set WSH = Nothing
Exit Sub
End If
ZZ = ZZ + 1
Wend
S = 3
NZ = Z + X
If ZZ >= LZ Then Exit For
Next
LZ = WSH.[a65536].End(xlUp).Row
For Z = LZ To 1 Step -1
If WSH.Cells(Z, 1).Interior.ColorIndex = 19 Then
WSH.Rows(Z).Delete
End If
Next
''Sortieren, um Leerzeilen zu entfernen.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With

''Objektvariable löschen
Set WSH = Nothing

End Sub

Anzeige
Re: Jetzt aber...immer noch nicht
25.11.2002 10:56:11
Marcel
Hallo, fast .. jetzt bleiben die einzelnen da. aber bei denen, wo es mehrere gibt, stimmt zwar die anzahl, die nebeneinander geschrieben werden, aber der erste wert wird doppelt eingetragen und der letzte verschluckt.
Re: endgültige Lösung
26.11.2002 15:59:08
Marcel
Ich habe jetzt für alle, die es interessiert die endgültige Lösung selbst herausbekommen.

Option Explicit
''Die Daten beginnen in Zelle A1, der Suchbegriff(AFNR) muss
''eine Ganzzahl sein, ansonsten die Variable SB als Variant oder
''als String deklarieren!
Sub zusammenfassen()
Dim SB As Long ''Suchbegriff ggf. als Variant oder String deklarieren!
Dim WSH As Worksheet, LZ As Long, Z As Long, ZZ As Long
Dim X As Long, S As Integer, NZ As Long
''Tabellenname ggf. anpassen!
Set WSH = ThisWorkbook.Sheets("Tabelle1")
LZ = WSH.[a65536].End(xlUp).Row
If LZ = 1 Then Exit Sub
ZZ = 1
S = 2 'nicht zu spät anfangen
X = 1
NZ = 1
''Code beschleunigen
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
''Erstmal sortieren, falls noch nicht sortiert ist.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For Z = 1 To LZ
''SB muss Ganzzahl sein oder siehe weiter oben!
SB = Cells(ZZ, 1).Value
While WSH.Cells(ZZ, 1).Value = SB And X < LZ
If WSH.Cells(ZZ + 1, 1) = SB Then
WSH.Cells(NZ, S) = WSH.Cells(ZZ, 2)
WSH.Cells(ZZ + 1, 1).Interior.ColorIndex = 19
X = X + 1
End If
''Falls die max. Anzahl der Spalten überschritten wird!
If S <= 255 Then
S = S + 1
Else
MsgBox "Maximum von 256 Spalten erreicht!" & Space(10), 64, "weise hin..."
Set WSH = Nothing
Exit Sub
End If
ZZ = ZZ + 1
Wend
WSH.Cells(NZ, S-1) = WSH.Cells(ZZ-1, 2) 'Wert eintragen auch bei nichterfüllter Bedingung (ganz wichtig)
S = 2
NZ = Z + X
If ZZ >= LZ Then Exit For
Next
LZ = WSH.[a65536].End(xlUp).Row
For Z = LZ To 1 Step -1
If WSH.Cells(Z, 1).Interior.ColorIndex = 19 Then
WSH.Rows(Z).Delete
End If
Next
''Sortieren, um Leerzeilen zu entfernen.
WSH.Columns("A:IV").Sort Key1:=WSH.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With

''Objektvariable löschen
Set WSH = Nothing

End Sub
So funktionierts. Danke nochmal an Ralf Sögel

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige