AW: Ergebnisse mittels Makro verschieben
04.07.2013 11:56:43
Hajo_Zi
du solltest Spalte B schon auf a ändern.
Option Explicit ' Variablendefinition erforderlich
Sub Umordnen()
'* H. Ziplies *
'* 08.11.12 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
' ein Datensatz besteht immer aus der gleichen Anzahl von Zeilen
' (einschl. Leerzeile)
' die Anzahl wird abgefragt, die Daten sind in Spalte B
' falls Spalte A belegt ist dies der Tabellenkopf
' es werden die Daten vom ersten Datensatz übernommen
' die Datensätze werden umgeordnet von einer Spalte in mehreren Zeilen
Dim LoLetzte As Long ' letzte Zeile
Dim LoZeile As Long ' Zeile in die geschrieben wird
Dim RaFound As Range ' Suchergebnis für Datensatzlänge
Dim LoAnzahl As Long ' Zellen je Datensatzanzahl
Dim LoI As Long ' Schleifenvariable
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
With ActiveSheet
' letzte Zeile in der Datentabelle feststellen in Spalte B (2)
LoLetzte = IIf(IsEmpty(.Cells(Rows.Count, 1)), _
.Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count)
Set RaFound = .Range("A1:A" & LoLetzte).Find("", .Range("A" & LoLetzte) _
, , xlWhole, , xlNext)
If RaFound Is Nothing Then
LoAnzahl = 5 ' fester Wert da keine Leerzelle in SpaltE _
B
Else
LoAnzahl = RaFound.Row ' Anzahl entsprechend Leerzeile
End If
Set RaFound = Nothing ' Variable leeren
' Abfrage Zellen je Datensatz. Inputbox mit Type 0, nur Zahlen als Eingabe
LoAnzahl = Application.InputBox("Bitte geben Sie die Anzahl " & "der Zeilen je _
Datensatz ein." _
& Chr(13) & "(einschl. Leerzeile)", "Zeilen je Datensatz", LoAnzahl, Type:=1)
LoAnzahl = Fix(LoAnzahl) ' Eingabe umwandeln in Ganzzahl
Select Case LoAnzahl
Case Is .Columns.Count
MsgBox "Excel hat nur " & .Columns.Count & " Spalten"
Case Else
' neue Tabelle einfügen, kein eigener Name
Sheets.Add After:=Sheets(Sheets.Count)
' If .Cells(1, 1) "" Then ' Prüfen ob Tabellenkopf
' ' Tabellenkopf schreiben einschl. Format und drehen um 90°
' .Range(.Cells(1, 1), .Cells(LoAnzahl, 1)).Copy
' Cells(LoZeile + 1, 1).PasteSpecial Paste:=xlAll, Transpose:=True
' LoZeile = LoZeile + 1
' End If
' Schleife über alle Datensätze
For LoI = 1 To LoLetzte Step LoAnzahl
' Datensatz umschreiben
.Range(.Cells(LoI, 1), .Cells(LoI + LoAnzahl - 1, 1)).Copy
Cells(LoZeile + 1, 1).PasteSpecial Paste:=xlAll, Transpose:=True
LoZeile = LoZeile + 1
Next LoI
End Select
End With
Application.ScreenUpdating = True ' Bildschirmaktualisierzng ein
Application.CutCopyMode = False ' Zwischenspeicher löschen
End Sub
Gruß Hajo