Vba Markro für mehrere Dateien ermöglichen
13.01.2010 14:52:54
BENNY
Hallo,
habe ein riesen Problem: Ich soll für meinen Arbeitgeber folgenden VBA Code umbauen. Momentan kann man mit Hilfe dieses Codes eine .fdf Datei einlesen und sie wir in Excel in Zeile 1 (Überschrift) und 2 (Werte) ausgelesen.
Mein Chef möchte nun, dass man mehrere Dateien einlesen kann und diese dann eben in mehreren Zeilen untereinander stehen....
Praktisch diesen Code auf x-Dateien multiplizieren.
Ich habe überhaupt keine Ahnung und es wäre extrem wichtg für mich... Kann mir vielleicht jemand helfen? Ich wäre Euch so dankbar!
Benny
ublic
Sub DoAdobeImport()
Dim FName As Variant
Dim Sep1 As String
Dim Sep2 As String
Dim Sep3 As String
Dim Sep4 As String
Dim RowNdx As Integer
Dim ColNdx As Integer
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim StartPos As Integer
Dim EndPos As Integer
Dim recordPos As Integer
Dim recordPos2 As Integer
Dim SaveColNdx As Integer
Dim Part1 As String
Dim Part2 As String
'get name of FDF file
FName = Application.GetOpenFilename _
(filefilter:="Adobe FDF Data Files(*.fdf),*.fdf,All Files (*.*),*.*", Title:="Select FDF _
file to import")
If FName = False Then
MsgBox "You didn't select a file"
Exit Sub
End If
'Set record separators
Application.ScreenUpdating = False
Sep1 = "<<"
Sep2 = ">>"
Sep3 = "/T"
Sep4 = ")"
'set cell row and column where to start entering data
ColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row
Open FName For Input Access Read As #1 'open fdf file
Line Input #1, WholeLine 'Skip first three lines as they do not contain any data
Line Input #1, WholeLine
Line Input #1, WholeLine
Line Input #1, WholeLine
StartPos = (InStr(1, WholeLine, "[")) + 1 ' find where data starts
EndPos = (InStr(1, WholeLine, "]")) - 1 ' find where data ends
WholeLine = Mid(WholeLine, StartPos, EndPos) 'capture just the data fields
Pos = 3 ' set start position
NextPos = InStr(Pos, WholeLine, Sep2) 'find end of current record
While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos) 'Find start of next record
recordPos = (InStr(1, TempVal, Sep4)) 'Go to end of record by using ")"
'Assume the value is in A1, in B1 =Left(A1,len(A1)-2)
Part1 = Trim(Mid(TempVal, 1, recordPos)) 'get data record name
'*******Comment out the line below if you do not want data record name*****
Cells(RowNdx, ColNdx).Value = Right((Left(Part1, Len(Part1) - 1)), Len((Left(Part1, Len( _
_
_
_
Part1) - 1))) - 3) ' trim off start and end superfluous characters and enter in cell
'*******Comment out the line below if you do not want data record name*****
RowNdx = RowNdx + 1 'move to next row
recordPos2 = (InStr(1, TempVal, Sep4)) ' find ")" which is end of record
Part2 = Trim(Mid(TempVal, recordPos2)) 'get data
'Check to see if data field is blank
If Part2 = Sep4 Then
Cells(RowNdx, ColNdx).Value = ""
'Check if Data is Yes or No
ElseIf Right(Part2, 1) <> Sep4 Then 'trim off start and end superfluous characters and _
_
_
_
enter in cell
Cells(RowNdx, ColNdx).Value = Right((Left(Part2, Len(Part2) - 0)), Len((Left(Part2, Len( _
_
_
_
Part2) - 0))) - 4) ' trim off start and end superfluous characters and enter in cell
Else
Cells(RowNdx, ColNdx).Value = Right((Left(Part2, Len(Part2) - 1)), Len((Left(Part2, Len( _
_
_
_
Part2) - 1))) - 4) ' trim off start and end superfluous characters and enter in cell
End If
'Cells(RowNdx, ColNdx).Value = Trim(Mid(TempVal, recordPos2)) 'Second part which _
contains data
ColNdx = ColNdx + 1 ' move to next column
'*******Comment out the line below if you do not want data record name*****
RowNdx = RowNdx - 1 ' move up a row
Pos = NextPos + 4 ' move to start of next record record
NextPos = InStr(Pos, WholeLine, Sep2) ' find end of next record
'if more records loop again
Wend
'if no more records end
Close #1
End Sub