Benutzer:UlrichAAB/Wiki2Excel
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