Also für dieses problem musst Du Dir ein Makro schreibenAnbei eine Funktion die macht zwar was anderes
aber ich denke du kannst einiges an Code davon verwenden:
(Wird wahrscheinlich so nicht funktionieren)
Private Sub cmdimport_Click()
Dim FilesToOpen As Variant
Dim Dateidaten As String
Dim zeilenarr() As String
Dim z1() As String
Dim z2() As String
Dim kommas() As String
Dim i As Long
Dim Script As String
Dim Fieldname As String
Dim j As Integer
Dim x As Integer
Dim startposition As Integer
Dim Labelzeile() As String
Dim NOLABEL As Boolean
Dim s As Integer
Dim label As Boolean
Dim Labelstr() As String
Dim Zeile() As String
Dim fieldnamsng As String
Dim multinenn() As String
Dim HlpKontroll As Integer
Dim HlpOff As Integer
Dim Text2Cod() As String
Dim FrageText As String
i = 0
Multinennung = False
MultiNr = 0
LabelAnz = 0
On Error Resume Next
FilesToOpen = Application.GetOpenFilename( _
"VAR Files (*.var), *.var", , "Var-File", , True)
If Not IsArray(FilesToOpen) Then
Exit Sub '!!!!!!!!!
End If
Workbooks.Add
CodFileName = Left(FilesToOpen(1), Len(FilesToOpen(1)) - 3) + "COD"
Open FilesToOpen(1) For Input As #1 ' Datei zum Einlesen öffnen.
ReDim FieldNames(5000)
ReDim Startpos(5000)
ReDim Lenght(5000)
ReDim Zeile(15000)
ReDim Text2Cod(15000)
Do While Not EOF(1) ' Auf Dateiende abfragen.
i = i + 1
Line Input #1, Dateidaten ' Datenzeilen lesen.
Zeile(i) = Dateidaten
Loop
Close #1 ' Datei schließen.
' Datei schließen, bevor sie in einem anderen Modus erneut
' geöffnet wird.
ReDim Preserve Zeile(i)
i = 0
For x = 1 To UBound(Zeile())
If Left(Zeile(x), 2) <> "**" Then
Dim Var2Import As Boolean
If Left(Zeile(x), 1) = "*" Then ' Falls andere Variable die nicht mit V beginnt diese nicht importieren
Var2Import = False
End If
If Left(Zeile(x), 2) = "*V" Then
Var2Import = True
'Begin Create Table
While Right(Zeile(x), 1) = "\"
Zeile(x) = Left(Zeile(x), Len(Zeile(x)) - 1) + Zeile(x + 1)
x = x + 1
Zeile(x) = Zeile(x - 1)
Wend
split Zeile(x), ":", zeilenarr(), 2
split zeilenarr(0), " ", z1()
If UBound(z1()) > 1 Then
If z1(1) = "*MV" Then
'Multinennung aufteilung auf mehrere Felder
FrageText = ""
If Left(z1(1), 1) = "*" Then
split z1(2), "L", z2()
Else
split z1(1), "L", z2()
End If
startposition = z2(0)
For j = 0 To z2(1) * 2
If j = 0 Then
'erstes Feld
fieldnamsng = Right(z1(0), Len(z1(0)) - 1)
Text2Cod(i + 1) = zeilenarr(1)
'FrageText = zeilenarr(1)
Else
i = i + 1
If Left(Zeile(x + j), 1) = "*" Then
Exit For
Else
'
If IsNumeric(Left(Trim(Zeile(x + j)), 1)) Then
split Zeile(x + j), ":", multinenn()
Fieldname = fieldnamsng & "#" & Right("00" & Trim(multinenn(0)), 2)
If Left(Fieldname, 1) = "*" Then
x = x - j + z2(1)
Exit For
End If
Script = Script & Chr(10) & Fieldname & " int,"
' end Create Table Script
FieldNames(i) = Fieldname
startposition = z2(0) + Val(Trim(multinenn(0))) - 1
Startpos(i) = startposition
Lenght(i) = 1
If j = 0 Then
Text2Cod(i) = Text2Cod(i) + Chr(10) + Zeile(x - 1)
End If
Text2Cod(i) = Text2Cod(i) + Chr(10) + Zeile(x + j)
Else
Text2Cod(i + 1) = Text2Cod(i) + Chr(10) + Zeile(x + j)
End If
End If
End If
Next j
Else
'ALle Anderen Nennungen
i = i + 1
Fieldname = Right(z1(0), Len(z1(0)) - 1)
If Left(z1(1), 1) = "*" Then
split z1(2), "L", z2()
Else
split z1(1), "L", z2()
End If
Startpos(i) = z2(0)
Lenght(i) = z2(1)
Text2Cod(i) = Text2Cod(i) + Chr(10) + zeilenarr(1)
FieldNames(i) = Fieldname
End If
End If
Else
If (IsNumeric(Left(Trim(Zeile(x)), 1)) And (Var2Import = True)) Then
Text2Cod(i) = Text2Cod(i) + Chr(10) + Zeile(x)
End If
End If
End If
Next x
ReDim Preserve FieldNames(i)
ReDim Preserve Startpos(i)
ReDim Preserve Lenght(i)
Cells.Select
Selection.ClearContents
Selection.ClearFormats
Selection.ClearOutline
'Codeplan
ActiveSheet.Cells(1, 1).Value = "Question"
ActiveSheet.Cells(1, 2).Value = "StartPos"
ActiveSheet.Cells(1, 3).Value = "EndPos"
ActiveSheet.Cells(1, 4).Value = "Lenght"
HlpKontroll = 0
HlpOff = 2
For x = 0 To i
If Val(Lenght(x)) > 0 Then
If Val(Startpos(x)) - 1 <> HlpKontroll Then
ActiveSheet.Cells(x + HlpOff, 1).Value = ".BLANK"
ActiveSheet.Cells(x + HlpOff, 2).Value = HlpKontroll + 1
ActiveSheet.Cells(x + HlpOff, 3).Value = Val(Startpos(x)) - 1
ActiveSheet.Cells(x + HlpOff, 4).Value = (Val(Startpos(x)) - 1) - HlpKontroll
If (ActiveSheet.Cells(x + HlpOff, 4).Value) < 1 Then
MsgBox "Achtung Fehler im Codeplan Zeile:" & Format(x + HlpOff, "#")
End If
HlpOff = HlpOff + 1
End If
HlpKontroll = Val(Startpos(x)) + Val(Lenght(x)) - 1
ActiveSheet.Cells(x + HlpOff, 1).Value = FieldNames(x)
ActiveSheet.Cells(x + HlpOff, 2).Value = Val(Startpos(x))
ActiveSheet.Cells(x + HlpOff, 3).Value = Val(Startpos(x)) + Val(Lenght(x)) - 1
ActiveSheet.Cells(x + HlpOff, 4).Value = Val(Lenght(x))
Hlpstr = Replace(Text2Cod(x), "\" + Chr(10), "")
If Left(Hlpstr, 1) = Chr(10) Then
Hlpstr = Right(Hlpstr, Len(Hlpstr) - 1)
End If
ActiveSheet.Cells(x + HlpOff, 5).Value = Hlpstr
' ActiveSheet.Cells(x + HlpOff, 6).Value = Labelstr(x)
' ActiveSheet.Cells(x + HlpOff, 7).Value = multinenn(x)
Else
HlpOff = HlpOff - 1
End If
Next x
AdjustPage
On Error GoTo 0
AdjustRows
End Sub