01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69 |
|
Sub Lua_Import()
Dim WSh As Worksheet, iff As Integer
Dim sFilename As String, sWert As String
Dim sArr() As String, sRette(6) As String
Dim iZeile As Long, iSpalte As Long, i As Long, j As Long
Dim sArrOut() As String, iZeileOut As Long
Set WSh = ThisWorkbook.Worksheets("Lua_Import") ' Blatt referenzieren
sFilename = "C:\Users\voltm\Desktop\Auctionator.lua" ' Dateinamen vorgeben
If Dir(sFilename) <> "" Then ' Ist Datei vorhanden?
sArr = Split("Main Ebene1 Ebene2 Ebene3 Ebene4 Wert")
ReDim Preserve sArrOut(5, 0)
For i = 0 To 5: sArrOut(i, 0) = sArr(i): Next i ' Kopfdaten schreiben
iff = FreeFile
Open sFilename For Input As iff ' Datei öffnen
sArr = Split(Input(LOF(iff), iff), vbCrLf) ' Daten in Array einlesen
Close iff ' Datei schließen
iZeile = 1: iSpalte = 1: iZeileOut = 1 ' Startparameter setzen
WSh.Cells.ClearContents
For i = 0 To UBound(sArr) ' Letzte Zeile im Array
sWert = Replace(sArr(i), Chr$(34), "")
sWert = Replace(Replace(sWert, "[", ""), "]", "")
If sWert <> "" Then
ReDim Preserve sArrOut(5, iZeile)
For j = 1 To 6
sArrOut(j - 1, iZeile) = sRette(j)
If Mid$(sArr(i), j, 1) <> vbTab Then ' Position über Tab ermitteln
sWert = Replace(sWert, vbTab, "")
sRette(j) = Trim$(Split(sWert, "=")(0)) ' Wert für später retten
Exit For
End If
Next j
Select Case Right$(sArr(i), 1)
Case ","
If Right$(sArr(i), 2) <> "}," Then ' Wert extrahieren
sWert = Replace(sWert, vbTab, "")
sWert = Left$(sWert, Len(sWert) - 1)
sArrOut(j - 1, iZeile) = Trim$(Split(sWert, "=")(0))
sArrOut(5, iZeile) = Trim$(Split(sWert & "=", "=")(1))
iZeile = iZeile + 1
End If
Case "}" ' Ende Collection
Case "{"
sArrOut(j - 1, iZeile) = sRette(j) ' Neue Collection
If sArr(i + 1) Like "*}," Then iZeile = iZeile + 1
Case Else
sArrOut(j - 1, iZeile) = sArr(i) ' Restliche falls vorkommt
iZeile = iZeile + 1
End Select
End If
If iZeile >= 65000 Then ' Transpose Maximum erreicht...
WSh.Cells(iZeileOut, "A").Resize(iZeile, 6).Value = Application.Transpose(sArrOut)
iZeileOut = iZeileOut + 65000
Erase sArrOut
iZeile = 0
End If
Next i
WSh.Cells(iZeileOut, "A").Resize(iZeile, 6).Value = Application.Transpose(sArrOut)
End If
MsgBox "Fertig"
End Sub
|