Kreuztabelle exportieren

wandelt eine Kreuztabelle in eine Tabelle um und exportiert diese in ein csv-File.

Die erste zu exportierende Zelle (in meinem Beispiel B3) anklicken und dann das Script ausführen. Anschließend Dateinahmen eingeben. Das Script exportiert die Kreuztabelle nun zeilenweise.

Daten in der Kreuztabelle
Daten in der Kreuztabelle
umgewandelte Kreuztabelle
umgewandelte Kreuztabelle

Sub kreuztabelle_exportieren()
    'Dieses Werk oder Inhalt ist unter 
    'einer Creative Commons-Lizenz lizenziert.
    'www.hotcursors.de
f = FreeFile(0)
fname = Application.GetSaveAsFilename( _
        InitialFileName:=strInitName, _
        FileFilter:="Text-Dateien (*.csv), *.csv", _
        Title:="Datei exportieren")
startrow = Selection.Row
startcol = Selection.Column
If fname <> False Then
    nrow = 0
    Open fname For Output As #f
    While Cells(startrow + nrow, startcol - 1).Value > ""
        kdnr = Cells(startrow + nrow, startcol - 1).Value
        col = 0
        ausgabe = ""
        While Cells(startrow - 1, startcol + _
             col).Value > ""
            If Cells(startrow + nrow, startcol + col)_
                     .Value > "" Then
                'reihen auslesen und schreiben
                ausgabe_row = ""
                For counter = 1 To startrow - 1
                    ausgabe_row = ausgabe_row & _
                         Cells(counter, startcol _ 
                               + col).Value & ";"
                Next counter
                'zeilen auslesen und schreiben
                ausgabe_col = ""
                For counter = 1 To startcol - 1
                    ausgabe_col = ausgabe_col &  _
                         Cells(startrow + nrow, _
                              counter).Value & ";"
                Next counter
                'datenpunkte auslesen und schreiben
                Print #f, ausgabe_row & ausgabe_col & _
                     Cells(startrow + nrow,  _
                          startcol + col).Value
            End If
            col = col + 1
        Wend
        nrow = nrow + 1
    Wend
    Close #f
End If ' file
MsgBox ("Export fertig.")
End Sub

Flattr this!