Excel 2003 - Makro

[Pulvertoastmann]

Hallo CB Gemeinde,

stehe hier vor einem kleinen Problem; habe in einer Excelliste Daten in der Spalte A die
ich mir gerne in waagerechter Form anzeigen lassen möchte, sprich Daten die zusammengehören auf die Zellen A-B-C usw. verteilen. Derzeit siehts so aus (siehe Anhang)

Hätte es aber gerne so in einem anderen Tabellenblatt am besten per Makro "eingespielt"

Ich weiß das dieses per Kopieren und dann Inhalte einfügen -> Transponieren auch möglich ist jedoch ist dies sehr aufwendig für 2000 und mehr Datensätze zu tun, deshalb
meine Frage ob jemand da eine Möglichkeit kennt dies per Makro zu erledigen.

Danke und Gruß
Pulver

 

[Mr. Snoot]

Im Grunde brauchst du nur den Makrorekroder anwerfen, einmal kopieren und transponieren, (Rekorder stoppen), und du siehst im VBA-Editor (Alt + F11) wie der Code dafür aussieht und kannst ihn dann ggf. allein an deine Bedürfnisse anpassen. Bspw.:

Sub Makro1()
    Range("A1:A5").Select [COLOR="green"]'das hier wurde ausegwählt ..[/COLOR]
    Selection.Copy [COLOR="green"]'... und kopiert[/COLOR]
    Sheets("Tabelle2").Select [COLOR="green"]'Tabellenblatt2 wird aufgerufen[/COLOR]
    Range("A1").Select [COLOR="green"]'Zelle A1 markiert ...[/COLOR]
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True [COLOR="green"]'... und das Kopierte dort eingefügt[/COLOR]
End Sub

 

[Pulvertoastmann]

Besten Dank für den Tip.

Nur sind leider meine VBA-Kentnisse so gut wie nicht vorhanden.
Hab da grad ein wenig versucht rumzubasteln jedoch ist nur Murks bei rumgekommen. Dein Makro
hat aber prima mit dem ersten Datensatz gefunzt.

Ich weiß leider nicht wie ich den Befehl "fortführen" kann nach dem Motto "Spring zurück in Spalte A und greif dir die nächsten Daten kopiere diese und transponiere sie in Sheet 2 unter die bereits vorhandenen Daten". Meine Ursprungsdaten aus Spalte A sind immer mit zwei Leerzellen von einander getrennt (hoffe das dient als eine Art Bezug). Mein Gott hab ich das kompliziert formuliert.

 

[Mr. Snoot]

Hast du immer dieselbe Anzahl an Werten pro 'Block'? Dann könnte man eine Schleife machen und einfach um denselben Betrag hochzählen. Andernfalls müsste man prüfen, wo die nächste Leerzeile beginnt.

 

[Pulvertoastmann]

Nein leider nicht. die Anzahl variiert meißtens zwischen 4-6 Werten pro "Block".

 

[Mr. Snoot]

Probier mal das:

Sub transponieren()

Dim iZeilen As Integer
Dim iZeilenproBlock As Integer
Dim iLeerzeilen As Integer
Dim i As Integer
Dim k As Integer
Dim wksTab1 As Worksheet
Dim wksTab2 As Worksheet

Set wksTab1 = Worksheets("Tabelle1") [COLOR="green"]'Quell-Tabelle[/COLOR]
Set wksTab2 = Worksheets("Tabelle2") [COLOR="Green"]'Zieltabelle[/COLOR]

iLeerzeilen = 2 [COLOR="green"]'Anzahl Leerzeilen zwischen Bloecken[/COLOR]
iZeilen = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row [COLOR="green"]'Gesamtanzahl der Zeilen in Tab1, Spalte A[/COLOR]
k = 1 [COLOR="green"]'Zielzeile in Tab2[/COLOR]

For i = 1 To iZeilen
  iZeilenproBlock = wksTab1.Range("A" & i).CurrentRegion.Rows.Count [COLOR="green"]'Anzahl der Zeilen im aktuellen Block[/COLOR]
  Range("A" & i & ":A" & i + iZeilenproBlock - 1).Copy [COLOR="green"]'Block kopieren[/COLOR]

  wksTab2.Range("A" & k).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True [COLOR="green"]'Block in Tab2 einfuegen[/COLOR]
  i = i + iLeerzeilen + iZeilenproBlock - 1 [COLOR="green"]'Startzeile des nächsten Blocks[/COLOR]
  k = k + 1 [COLOR="green"]'Zielzeile um eins erhoehen[/COLOR]
Next i

End Sub

 

[Pulvertoastmann]

Hey Snoot Danke für die Mühe.

Habs grad angetestet mit zwei "Blöcken" da funktioniert es super.
Habe ich aber 3 oder mehr verschiebt sich der kopierte Bereich um eine Zelle und im
zweiten Blatt erscheinen die Daten halt nicht komplett.

 

[Mr. Snoot]

Kannste mal eine Biespieltabelle hochladen? Bei mir klappt das einwandfrei.

 

[Pulvertoastmann]

bitte aus .txt .xls machen. will keine xls annehmen beim hochladen.

 

[GMG-CC]

Moin Pulvertoastmann,

das sollte funktionieren:

Sub MyTranspose()
   Dim LastRow As Long
   Dim Inhalt As Variant
   Dim Ze1 As Long, Ze2 As Long, Sp2 As Integer
   Dim i As Integer, k As Integer
   Dim T1 As Worksheet, T2 As Worksheet
   
   Set T1 = Worksheets("Tabelle1")
   Set T2 = Worksheets("Tabelle2")
   LastRow = T1.Cells(Rows.Count, 1).End(xlUp).Row
   
   Ze1 = 1
   Ze2 = 1
   Sp2 = 1
   Do While Ze1 <= LastRow
      Inhalt = Trim(T1.Cells(Ze1, 1).Value)
      If Inhalt > "" Then
         T2.Cells(Ze2, Sp2).Value = Inhalt
         Sp2 = Sp2 + 1
      Else
         Ze1 = Ze1 + 1
         Ze2 = Ze2 + 1
         Sp2 = 1
      End If
      Ze1 = Ze1 + 1
   Loop
End Sub

Da können die Blöcke auch verscheiden groß sein, macht nichts.
Mir ist klar, dass das auch noch etwas eleganter geht, aber so ist es verständlicher

 

[Pulvertoastmann]

Moin Nemo,

elegant genug das es einwandrei funktioniert

Millionenfachen Dank