Bestimmte Zellen kopieren

Bild

Betrifft: Bestimmte Zellen kopieren
von: Uwe
Geschrieben am: 04.11.2003 12:56:37

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

Bild


Betrifft: AW: Bestimmte Zellen kopieren
von: Jürgen K.
Geschrieben am: 04.11.2003 13:52:54

Hi Uwe,

mal angenommen, Die Bezeichnungen (Name, Ort...) stehen in der Spalte A1:Ax untereinander, die dazugehörigen Werte in der Spalte B1:Bx. Dann selektiere die
Zelle A1 und laß dieses Makro darüber laufen. Es schreibt die Werte für Name, Ort und Plz (ggf. im Code korrigieren, sie müssen identisch sein mit Deinen Bezeichnungen) untereinander in die Spalten C, D und E (Diese SPalten sollten also leer sein!). Wo mehr als diese drei Infos in der
Spalte A untereinander stehen, entstehen in der neuen Auflistung z. T. leere Zeilen,
aber das sollte nicht das Problem sein (die Daten werden jedenfalls vollständig übernommen).

Diese neue Liste kannst Du dann in ein neues Blatt kopieren.




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



Gruß, Jürgen


Bild


Betrifft: AW: Bestimmte Zellen kopieren
von: Jürgen K.
Geschrieben am: 04.11.2003 14:10:23

.. da steckt noch ein Fehler drin, das Makro kann unter ungünstigen Umständen Datensätze überschreiben.

Ich schau gleich mal nach wo dran es liegt...


Bild


Betrifft: AW: Bestimmte Zellen kopieren
von: Uwe
Geschrieben am: 04.11.2003 14:39:58

Das ist schon genial. Aber ab der 4. Position werden die kopierten Zellen in Spalte C,D,E etc. immer eine nach unten verschoben. Kann man das noch ändern?

Grüsse und vielen Dank


Bild


Betrifft: AW: Bestimmte Zellen kopieren
von: Jürgen K.
Geschrieben am: 04.11.2003 16:10:48

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



Bild


Betrifft: AW: Bestimmte Zellen kopieren
von: Uwe
Geschrieben am: 04.11.2003 16:45:11

Toll, das funktioniert wirklich spitze !!!!

Finde ich ja sagenhaft.

Vielen Dank Jürgen

und liebe Grüsse
Uwe


Bild

Beiträge aus den Excel-Beispielen zum Thema " Bestimmte Zellen kopieren"