Bestimmte Zellen kopieren

Hallo, ich bin neu hier und heisse Uwe,
das Forum gefällt mir sehr gut. Vielleicht könnt´ihr mir bei meinem Problem auch helfen.
Ich habe eine Tabelle mit 2 Spalten. In der ersten Spalte wiederholen sich bestimmte Bezeichnungen [Name, Ort, PLZ]. In der 2. Spalte sind die Werte. Dies ist in Blöcken. Die Blöcke unterscheiden sich in der Länge, da noch Zusätze wie [email, Internet] vorhanden sind. Ich möchte jetzt von der 1. Spalte nur die Zeilen mit den Bezeichnungen [Name, Ort und PLZ] mit der entsprechenden Zeile in der 2. Spalte in eine neue Mappe kopieren und so transponieren, das die drei Bezeichnungen als Spaltenüberschrift nur einmal erscheinen und darunter dann die Werte gelistet werden.
Ganz schön schwierig.

Über eine Lösung würde ich mich sehr freuen.

Grüsse
Uwe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Sortieren() Dim Zeile As Integer Zeile = 0 Do Until ActiveCell.Value = Empty If ActiveCell.Value = "Name" Then ActiveCell.Offset(Zeile, 2).Value = ActiveCell.Offset(0, 1).Value Zeile = Zeile - 1 End If If ActiveCell.Value = "Ort" Then ActiveCell.Offset(Zeile, 3).Value = ActiveCell.Offset(0, 1).Value Zeile = Zeile - 1 End If If ActiveCell.Value = "PLZ" Then ActiveCell.Offset(Zeile, 4).Value = ActiveCell.Offset(0, 1).Value Zeile = Zeile - 1 End If ActiveCell.Offset(1, 0).Select Loop End Sub

Hi Uwe,

hat ein bischen gedautert, aber dass hier müsste jetzt funktionieren.
Die Bezeichnungen müssen dazu in der Spalte A stehen, sonst musst Du den Code ent-
sprechend ändern.

Gruß, Jürgen


Sub Sortieren()
Dim Zeile As Integer
Dim Name As String
Dim Ort As String
Dim Plz As String
Application.ScreenUpdating = False
Do Until ActiveCell.Value = Empty
If ActiveCell.Value = "Name" Then   'Gross- und Kleinschreibung beachten!
Name = ActiveCell.Offset(0, 1).Value
Zeile = ActiveCell.Row
Range("C1").Select
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Value = Name
Range("A" & Zeile).Select
End If
If ActiveCell.Value = "Ort" Then   'Gross- und Kleinschreibung beachten!
Ort = ActiveCell.Offset(0, 1).Value
Zeile = ActiveCell.Row
Range("D1").Select
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Value = Ort
Range("A" & Zeile).Select
End If
If ActiveCell.Value = "PLZ" Then   'Gross- und Kleinschreibung beachten!
Plz = ActiveCell.Offset(0, 1).Value
Zeile = ActiveCell.Row
Range("E1").Select
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Value = Plz
Range("A" & Zeile).Select
End If
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bestimmte Zellen kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread