Benutzer:UlrichAAB/Wiki2Excel

aus Wikipedia, der freien Enzyklopädie
Zur Navigation springen Zur Suche springen
'------------------------------------------------------------------------------
' UlrichAAB | 2011-10-03 | 1st version completed
'------------------------------------------------------------------------------
'
' Installation: Diese Makros in ein VB Modul in Excel kopieren
' und CreateExcel ausführen.
'
'------------------------------------------------------------------------------
' CreateExcel
'------------
' Erzeuge eine Excel-Tabelle aus Wikitext
' 1. kopiert Wikitext aus dem Clipboard nach Sheet "in"
' 2. erzeugt Sheet "table" aus der ersten Tabelle im Wikitext
'
' "table"
' 1. Zeile: B1 enthält die Tabellenüberschrift
' 2. Zeile und folgende enthalten die Tabelleninhalte
' 1. Spalte enthält Format-Strings:
'    A1 für die Tabelle. A2,A3 ... für die jeweilige Zeile
'
'------------------------------------------------------------------------------
' CreateWikiTable
'----------------
' Erzeugte eine Wiki-Tabelle aus dem Sheet "table" und
' legt diese in "out" und im Clipboard ab.
'
'------------------------------------------------------------------------------
' InsertWikiTable
'----------------
' Der ursprüngliche Text aus Sheet "in" wird übernommen und die erste
' Tabelle in diesem Text wird durch die Tabelle in "table" ersetzt.
'
'------------------------------------------------------------------------------


Option Explicit

Const PARAM_ZEILE_TABPARAMS = 1
Const PARAM_SPALTE_TABPARAMS = 1
Const PARAM_ZEILE_TITLE = 1
Const PARAM_SPALTE_TITLE = 2

Sub CreateExcel()
    Call Init
    Sheets("table").Cells.ClearContents
    Sheets("table").Cells.ClearComments

    Sheets("in").Select
    
' Wert Clipboard => Tabelle tmp
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    ActiveSheet.Paste
' Tabelle extrahieren
    ActiveSheet.UsedRange.Select
Dim zeileInMax As Integer
    zeileInMax = LastRow(Sheets("in")) 'Sheets("in").UsedRange.Count ist z.T. zu groß
    Dim h As String
    Dim zeileIn As Integer
        zeileIn = 1
    While zeileIn <= zeileInMax 'Tabellenanfang im Text suchen suchen
        h = Cells(zeileIn, 1)
        If Left(h, 2) = "{|" Then 'Tabellenanfang gefunden
            SetTabParams (Mid(h, 3))
            zeileIn = zeileIn + 1
            Dim zeileOut As Integer
                zeileOut = 0
            Dim spalteOut As Integer
                spalteOut = 1
            While zeileIn <= zeileInMax 'Tabelle bis Ende durchsuchen
                h = Cells(zeileIn, 1).Text
                If h <> "" Then ' Leerzeilen überspringen
                    If Left(h, 1) <> "!" And Left(h, 1) <> "|" Then
                        ErrorOut ("Tabelle fehlerhaft, Zeile" + Str(zeileIn) + ": " + h)
                        ErrorOut ("@show")
                        Exit Sub
                    End If
                    Dim boldFlag As Boolean
                    boldFlag = Left(h, 1) = "!"
                    Select Case Left(h, 2)
                        Case "|}" 'Tabellenende gefunden
                            Sheets("table").Select
                            Exit Sub
                        Case "|+" 'Überschrift
                            SetTabTitle (Mid(h, 3))
                        Case "|-" 'neue Zeile
                            zeileOut = zeileOut + 1
                            Call SetLineParams(Mid(h, 3), zeileOut)
                            spalteOut = 1
                        Case Else   ' Normale Tabellenzeile
                            Dim i As Integer
                            i = InStr2(1, h)
                            If i > 0 Then  'Zeile hatte mehrere Spalten
                                If Left(h, 2) = "||" Or Left(h, 2) = "!!" Then
                                    h = Mid(h, 2)
                                End If
                                Dim i0 As Integer
                                    i0 = 2
                                i = InStr2(1, h)
                                While i > 0
                                    Call SetZelle(zeileOut, spalteOut, Mid(h, i0, i - i0), boldFlag, "")
                                    i0 = i + 2
                                    i = InStr2(i0, h)
                                Wend
                                Call SetZelle(zeileOut, spalteOut, Mid(h, i0), boldFlag, "")
                                
                            Else 'Zeile hat nur eine Spalte
                                i = InStr1(2, h)
                                If i > 0 Then 'Zeile hat Formatparameter
                                    i0 = InStr1(2, h)
                                    Dim h2 As String
                                    h2 = Trim(Mid(h, 2, i0 - 2))
                                    Call SetZelle(zeileOut, spalteOut, Mid(h, i0 + 1), boldFlag, h2)
                                Else 'Zeile hat nut Wert
                                    Call SetZelle(zeileOut, spalteOut, Mid(h, 2), boldFlag, "")
                                End If
                            End If
                    End Select
                End If 'If h <> ""
                zeileIn = zeileIn + 1
            Wend
            ErrorOut ("Ende der Tabelle nicht gefunden")
            ErrorOut ("@show")
            Exit Sub
        End If
        zeileIn = zeileIn + 1
    Wend
    ErrorOut ("Anfang der Tabelle nicht gefunden")
    ErrorOut ("@show")
End Sub 'CreateExcel

Function InStr2(i As Integer, h As String) As Integer
    InStr2 = InStr(i, h, "||")
    If InStr2 > 0 Then Exit Function
    InStr2 = InStr(i, h, "!!")
    If InStr2 > 0 Then Exit Function
    InStr2 = InStr(i, h, "!|")
End Function

Function InStr1(i As Integer, h As String) As Integer
    InStr1 = InStr(i, h, "|")
    If InStr1 > 0 Then Exit Function
    InStr1 = InStr(i, h, "!")
End Function

Sub InsertWikiTable()
    Call Init
Dim zeileInMax As Integer
    zeileInMax = LastRow(Sheets("in")) 'Sheets("in").UsedRange.Count ist z.T. zu groß
    Dim h As String
    Dim zeileIn As Integer
    For zeileIn = 1 To zeileInMax
        h = Sheets("in").Cells(zeileIn, 1)
        If Left(h, 2) = "{|" Then 'Tabellenanfang gefunden
            Call CreateWikiTableSub
            While Left(Sheets("in").Cells(zeileIn, 1), 2) <> "|}" ' alte WikiTabelle in "in" überspringen
                zeileIn = zeileIn + 1
                If zeileIn > zeileInMax Then
                    ErrorOut ("Tabellenende in 'in' fehlt")
                    Sheets("error").Select
                    End
                End If
            Wend
            Dim zeileIn2
            For zeileIn2 = zeileIn + 1 To zeileInMax
                h = Sheets("in").Cells(zeileIn2, 1)
                OutLine (h) 'Zeile aus Sheet "in" übernehmen
            Next zeileIn2
            Sheets("out").UsedRange.Select
            Selection.Copy
            End
        End If
        OutLine (h)
    Next zeileIn
    ErrorOut ("Tabellenanfang in 'in' fehlt")
    Sheets("error").Select
End Sub 'InsertWikiTable

Sub CreateWikiTable()
    Call Init
    Call CreateWikiTableSub
    Sheets("out").UsedRange.Select
    Selection.Copy
End Sub

Private Sub CreateWikiTableSub()
    Sheets("table").Select
'    ActiveSheet.UsedRange.Select
Dim spalteTabMax As Integer
'    spalteTabMax = ActiveSheet.UsedRange.Columns.Count
    spalteTabMax = LastColumn(Sheets("table"))
Dim zeileTabMax As Integer
'    zeileTabMax = ActiveSheet.UsedRange.Rows.Count
    zeileTabMax = LastRow(Sheets("table"))
    'Tabellenanfang
    Dim tabParam As String
    tabParam = GetTabParams
    If tabParam = "" Then
        OutLine ("{|")
    Else
        OutLine ("{| " + tabParam)
    End If
    'Tabellenüberschirft
    Dim tabTitle As String
    tabTitle = GetTabTitle()
    If tabTitle <> "" Then
        OutLine ("|+ " + tabTitle)
    End If
    
    Dim zeileWiki As Integer
    For zeileWiki = 1 To zeileTabMax - 1
        Dim lineParam As String
        lineParam = GetLineParams(zeileWiki)
        If lineParam = "" Then
            OutLine ("|-")
        Else
            OutLine ("|- " + lineParam)
        End If
        Dim spalteWiki As Integer
        For spalteWiki = 1 To spalteTabMax - 1
            Dim format As String
            Dim cellText As String
            Dim boldFlag As Boolean
            cellText = GetZelle(zeileWiki, spalteWiki, boldFlag, format)
            Dim txt As String
            If boldFlag Then
                txt = "! "
            Else
                txt = "| "
            End If
            If format <> "" Then
                txt = txt + format + " | "
            End If
            txt = txt + cellText
            OutLine (txt)
        Next spalteWiki
    Next zeileWiki
    OutLine ("|}")
    Sheets("out").Select
End Sub 'CreateWikiTable

Sub SetZelle(zeileWiki As Integer, spalteWiki As Integer, ByRef cellText As String, boldFlag As Boolean, commentText As String)
    If zeileWiki = 0 Then
        zeileWiki = 1
    End If
    Dim zeile As Integer
    zeile = zeileWiki + 1
    Dim spalte As Integer
    spalte = spalteWiki + 1
    cellText = Trim(cellText)
    If Left(cellText, 1) = "'" Then
        cellText = "'" + cellText 'Fix: Excel unterdrück 1. '
    End If
    Sheets("table").Cells(zeile, spalte) = cellText
    If commentText <> "" Then
        Dim h As String
        h = Trim(commentText)
        Sheets("table").Cells(zeile, spalte).AddComment h 'Formatierung als kommentar ablegen
    End If
    If boldFlag Then
        Sheets("table").Cells(zeile, spalte).Font.FontStyle = "Bold"
    Else
        Sheets("table").Cells(zeile, spalte).Font.FontStyle = "Regular"
    End If
    spalteWiki = spalteWiki + 1
End Sub 'SetZelle

Function GetZelle(zeileWiki As Integer, spalteWiki As Integer, boldFlag As Boolean, formatText As String) As String
    Dim zeile As Integer
    zeile = zeileWiki + 1
    Dim spalte As Integer
    spalte = spalteWiki + 1
    GetZelle = Sheets("table").Cells(zeile, spalte).Text
    If Cells(zeile, spalte).Font.FontStyle = "Bold" Then
        boldFlag = True
    Else
        boldFlag = False
    End If
    formatText = GetComment(zeile, spalte)
End Function 'GetZelle

Function GetComment(zeile As Integer, spalte As Integer) As String
    On Error Resume Next
    Dim h
    h = Cells(zeile, spalte).comment.Text
    On Error GoTo 0
    If h = Empty Then
        GetComment = ""
    Else
        GetComment = h
    End If
End Function

Sub SetTabParams(paramText As String)
    Sheets("table").Cells(PARAM_ZEILE_TABPARAMS, PARAM_SPALTE_TABPARAMS) = Trim(paramText) ' Text hinter "{|" speichern
End Sub

Function GetTabParams() As String
    GetTabParams = Sheets("table").Cells(PARAM_ZEILE_TABPARAMS, PARAM_SPALTE_TABPARAMS) ' Text hinter "{|"
End Function

Sub SetLineParams(paramText As String, wikiZeile As Integer)
    Sheets("table").Cells(wikiZeile + 1, 1) = Trim(paramText) ' Text hinter "|+" speichern
End Sub

Function GetLineParams(wikiZeile As Integer) As String
    GetLineParams = Sheets("table").Cells(wikiZeile + 1, 1) ' Text hinter "|+"
End Function

Sub SetTabTitle(titleText As String)
    Sheets("table").Cells(PARAM_ZEILE_TITLE, PARAM_SPALTE_TITLE) = Trim(titleText) ' Text hinter "{|" speichern
End Sub

Function GetTabTitle() As String
    GetTabTitle = Sheets("table").Cells(PARAM_ZEILE_TITLE, PARAM_SPALTE_TITLE) ' Text hinter "{|"
End Function

Sub OutLine(ByVal txt As String)
Static zeileOut As Integer
    If txt = "@init" Then
'        Sheets("out").Cells.ClearContents
        Application.DisplayAlerts = False
        DeleteSheet ("out")
        Application.DisplayAlerts = True
        CreateSheet ("out")
        zeileOut = 0
        Exit Sub
    End If
    zeileOut = zeileOut + 1
    If Left(txt, 1) = "=" Then
        txt = "'" + txt
    End If
    Sheets("out").Cells(zeileOut, 1) = txt
End Sub

Sub ErrorOut(errorText)
Static errorZeile As Integer
    If errorText = "@init" Then
        CreateSheet ("error")
        errorZeile = 0
        Sheets("error").Cells.ClearContents
        Exit Sub
    End If
    If errorText = "@show" Then
        If errorZeile = 0 Then Exit Sub
        Sheets("error").Select
        Range("A1").Select
        Exit Sub
    End If
    errorZeile = errorZeile + 1
    Sheets("error").Cells(errorZeile, 1) = errorText
End Sub 'ErrorOut

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
    After:=sh.Range("A1"), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
    On Error GoTo 0
End Function 'LastRow

Function LastColumn(sh As Worksheet)
    On Error Resume Next
    LastColumn = sh.Cells.Find(What:="*", _
    After:=sh.Range("A1"), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Column
    On Error GoTo 0
End Function 'LastColumn

Private Sub Init()
    ErrorOut ("@init")
    OutLine ("@init")
    CreateSheet ("in")
    CreateSheet ("table")
End Sub

Sub CreateSheet(sheetName As String)
Dim i As Integer
    For i = 1 To Sheets.Count
        If Sheets(i).Name = sheetName Then
            Exit Sub
        End If
    Next i
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = sheetName
End Sub

Sub DeleteSheet(sheetName As String)
    On Error Resume Next
    Sheets("out").Delete
    On Error GoTo 0
End Sub