Makro zur Umformatierung einer Tabelle

[Karo.0102]

Hallo zusammen,

ich habe eine Tabelle, welche ich gerne mit Hilfe eines Makros umformatieren möchte, um die Daten dann in einer Pivotabelle weiter zu verwenden.

Im beigefügten Beispiel findet sich im Tabellenblatt "staffoutput" die Ursprungsdatei und im Tabellenblatt "Zielformat" befindet sich die gewünschte Formatierung für die ersten beiden Einträge.

In der Ursprungsdatei sind jeweils die Spalten variabel (Einträge von E4:??4) als auch die Zeilen (Eintrage von B5:B??). Das Makro sollte somit erkennen wie viele Spalten und Zeilen vorhanden sind und diese dann in ein neues Tabellenblatt im Format lt. "Zielformat" anführen. Zeilen mit Spent Sum = 0 könnten dann eigentlich gelöscht werden, wobei das ist eher ein "nice to have" als ein muss.

Da ich ein Makroanfänger bin und diese meist mit der Makroaufzeichnung erstelle, komme ich hier selbst nicht weiter und wäre froh um Unterstützung.

Besten Dank schon mal und liebe Grüsse,
Karo

[EbyAS]

Hallo,
kannst Du einmal erklären was das soll? Du hast dann eine intentische Tabelle das kann man einfacher erreichen! Copiere die Tabelle und fertig.

[Werner.M]

Hallo Karo,

keine Ahnung was du da vor hast aber dir ist schon klar, dass dein Ergebnisblatt dann mal lockere 476000 Zeilen hat?

Gruß Werner

[Wastl]

476000 Zeilen?

keine Ahnung was du da vor hast aber dir ist schon klar, dass dein Ergebnisblatt dann mal lockere 476000 Zeilen hat?

Nicht ganz, wenn man auch noch dem Extrawunsch nachkommt

Zeilen mit Spent Sum = 0 könnten dann eigentlich gelöscht werden, wobei das ist eher ein "nice to have" als ein muss.

einen ersten Ansatz, rest eventuell morgen

Code:

Sub ppivot()
Dim Suchzeile As Long
Dim Suchspalte As Long
Dim AusfüllZeile As Long

AusfüllZeile = 2

With Sheets("staffoutput")
For Suchspalte = 5 To 211
   For Suchzeile = 5 To 2300
       If .Cells(Suchzeile, Suchspalte).Value > 0 Then
           Sheets("Tabelle1").Cells(AusfüllZeile, 1) = .Cells(Suchzeile, 1)
           Sheets("Tabelle1").Cells(AusfüllZeile, 2) = .Cells(Suchzeile, 2)
           Sheets("Tabelle1").Cells(AusfüllZeile, 3) = .Cells(Suchzeile, 3)
           Sheets("Tabelle1").Cells(AusfüllZeile, 4) = .Cells(4, Suchspalte)
           Sheets("Tabelle1").Cells(AusfüllZeile, 5) = .Cells(Suchzeile, Suchspalte)
           AusfüllZeile = AusfüllZeile + 1
           If AusfüllZeile = 5000 Then Stop
       End If
   Next Suchzeile
Next Suchspalte
End With
End Sub

[Phi.VBA]

Hallo,

lege bitte für die Ausgabe ein Sheets("Phi") an. Danach zuerst T1, dann T2 starten. Die Laufzeit ist noch erträglich.

Code:

Sub T1()
For Each c In ActiveSheet.UsedRange
   If c.Value = 0 Then c.Clear
Next c
End Sub
Sub T2()
Dim rng As Range
r = 4
On Error Resume Next
Debug.Print Cells(4, Columns.Count).End(xlToLeft).Column
For Col = 5 To Cells(4, Columns.Count).End(xlToLeft).Column
   
       For Each ar In Columns(Col).SpecialCells(2, 1).Areas
       If Err.Number <> 0 Then GoTo fin
           Set rng = Union(Range(Cells(ar.Row, 1), Cells(ar.Row, 4)), ar)
           r = r + 1
           Range(Cells(ar.Row, 1), Cells(ar.Row, 3)).Copy Sheets("Phi").Cells(r, 1)
           Sheets("Phi").Cells(r, 4) = Cells(4, Col)
           Sheets("Phi").Cells(r, 5) = ar.Value
       Next ar
fin:
Err.Clear
application.statusbar = Col
Next Col
End Sub

[Ego]

Hallo Karo,

wenn man die Daten in ein Array einliest, im Arbeitsspeicher verarbeitet und aus einem Array ausgibt, sollte die Laufzeit um den Faktor 10-100 schneller sein. (Auf meinem Rechner ca 0,3 Sekunden).

Code:

Option Explicit
Sub Machs()
Dim lngZeileEin As Long
Dim lngZeileAus As Long
Dim lngSpalteEin As Long
Dim lngMaxZeilen As Long
Dim dblStart As Double
Dim varListe As Variant
Dim varAusgabe() As Variant
Dim rngAusgabe As Range

dblStart = Timer

varListe = ThisWorkbook.Names("Liste").RefersToRange.Value
Set rngAusgabe = ThisWorkbook.Names("Ausgabe").RefersToRange
lngMaxZeilen = (UBound(varListe, 1) - 1) * (UBound(varListe, 2) - 4) + 1
ReDim varAusgabe(1 To lngMaxZeilen, 1 To 5)

varAusgabe(1, 1) = varListe(1, 1)
varAusgabe(1, 2) = varListe(1, 2)
varAusgabe(1, 3) = varListe(1, 3)
varAusgabe(1, 4) = "Employee"
varAusgabe(1, 5) = varListe(1, 4)
lngZeileAus = 1

For lngSpalteEin = 5 To UBound(varListe, 2)
    For lngZeileEin = 2 To UBound(varListe, 1)
        If varListe(lngZeileEin, lngSpalteEin) <> 0 Then
            lngZeileAus = lngZeileAus + 1
            varAusgabe(lngZeileAus, 1) = varListe(lngZeileEin, 1)
            varAusgabe(lngZeileAus, 2) = varListe(lngZeileEin, 2)
            varAusgabe(lngZeileAus, 3) = varListe(lngZeileEin, 3)
            varAusgabe(lngZeileAus, 4) = varListe(1, lngSpalteEin)
            varAusgabe(lngZeileAus, 5) = varListe(lngZeileEin, lngSpalteEin)
        End If
    Next lngZeileEin
Next lngSpalteEin

rngAusgabe.Resize(lngZeileAus, 5).Value = varAusgabe

MsgBox Timer - dblStart

End Sub

ps.
1. Wenn sich die Anzahl der Zeilen oder Spalten ändern, muss man das Programm nicht anpassen, sondern nur den benannten Bereich "Liste".
2. Sowohl die "Liste" als auch die Zelle (mit dem Namen "Ausgabe" ab der die Ausgabe erfolgt) kann beliebig in der Datei verschoben werden ohne das Programm anpassen zu müssen.

[snb]

Verwende:

Code:

Sub M_snb()
    sn = Tabelle1.Cells(4, 1).CurrentRegion
 
    y = UBound(sn, 2) - 4
    ReDim sp((UBound(sn) - 1) * y, 4)
    
    For j = 0 To UBound(sp) - 1
       x = j \ y + 2
       Z = j Mod y + 5
       sp(j, 0) = sn(x, 1)
       sp(j, 1) = sn(x, 2)
       sp(j, 2) = sn(x, 3)
       sp(j, 3) = sn(1, Z)
       sp(j, 4) = sn(x, Z)
    Next

    Tabelle2.Cells(1, 10).Resize(UBound(sp), UBound(sp, 2) + 1) = sp
End Sub

[Wastl]

Hi snb,

das sieht verdammt kurz aus.
Ich habs ausprobiert. 
Es ist zu kurz.
Das Makro rödelt etwas, hört dann auf und Tabelle2 bleibt leer…
:20:
----------------------------------------------------------------------------------
Hi Ego,
flott, aber…

…der Dateiname ist nun festverdrahtet in den Namen und passt sich nicht automatisch an, wenn du beim Download die Datei umbenennst. So kommen die Fehlermeldungen (3) schon beim öffnen der Datei.

Warum gehst du überhaupt den Umweg über die Namen?
Solche Art der Programmierung habe ich schon mit XL2003 gemacht und damals festgestellt, dass es schwierig ist, die variable Länge und Breite einer Tabelle mit redim zu erschlagen.
Geht das nun bei neueren XL-Versionen gar nicht mehr?

[Ego]

Hallo Wastl,

deine Fehlerbeschreibung konnte ich nicht nachvollziehen. Ich habe auch noch nicht gehört, dass in den Namen der Dateiname fest verdrahtet ist.

Namen nutze ich, damit ich Dateien umstrukturieren kann, ohne die Programme anpassen zu müssen.

[snb]

Dein Feedback ist zu kurz.

Offensichtlich weisst du nicht das Tabelle2.Cells(1, 10) : range("J1") ist .

Hast du die Code in der hochgeladene Datei getestet ?