Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Vba Markro für mehrere Dateien ermöglichen | Herbers Excel-Forum


Betrifft: Vba Markro für mehrere Dateien ermöglichen von: BENNY
Geschrieben am: 13.01.2010 14:52:54

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

  

Betrifft: AW: Vba Markro für mehrere Dateien ermöglichen von: Luschi
Geschrieben am: 13.01.2010 15:28:28

Hallo BENNY,

versuch es mal so:

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
Dim goNext As Boolean

goNext = True
Do While goNext
'get name of FDF file
    FName = Application.GetOpenFilename(filefilter:="Adobe FDF Data Files(*.fdf)," & _
            "*.fdf,All Files (*.*),*.*", Title:="Select FDF file to import")

   'Dein Weiterer Code bis
   'if no more records end
   Close #1
   If MsgBox("Next 'fdf'-File?", 32 + vbYesNo, "Please answer...") = vbYes Then
      goNext = True
   Else
      goNext = False
   End If
End Sub

Lediglich folgende 2 Zeilen solltest Du noch so ändern:
ColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row

in

If RowNdx = 0 Then
   ColNdx = ActiveCell.Column
   RowNdx = ActiveCell.Row
End If
Gruß von Luschi
aus klein-Paris


  

Betrifft: AW: Vba Markro für mehrere Dateien ermöglichen von: Luschi
Geschrieben am: 13.01.2010 15:38:09

Hallo BENNY,

noch eine kleine Korrektur:
vor der Zeile End Sub fehlt noch ein Loop

also so:

   End If
   Loop
End Sub
Gruß von Luschi
aus klein-Paris


  

Betrifft: AW: Vba Markro für mehrere Dateien ermöglichen von: BENNY
Geschrieben am: 13.01.2010 16:05:50

Hi Luschi,

vielen, vielen, vielen Dank für Deine Antwort. Das hat mir zumindest schon etwas weitergeholfen.
Wenn ich Dich richtig verstanden habe, müsste der Code so ausschauen:

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
Dim goNext As Boolean

goNext = True
Do While goNext
'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
If RowNdx = 0 Then
   ColNdx = ActiveCell.Column
   RowNdx = ActiveCell.Row
End If
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
    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
If MsgBox("Next 'fdf'-File?", 32 + vbYesNo, "Please answer...") = vbYes Then
      goNext = True
   Else
      goNext = False
   End If
Loop
End Sub

Momentan habe ich jedoch 2 Probleme:
1. Wenn ich das Makro ausführe, öffnet sich das Dialogfenster zum Auswählen der FDF Dateien, ich kann jedoch nur eine Datei auswählen.
2. Wenn ich eine Datei einlesen will, erhalte ich die Fehlermeldung "Ungültiger Prozedurauflauf oder ungültiges Argument - Laufzeitfehler 5". Er markiert mir folgende Zeile:
WholeLine = Mid(WholeLine, StartPos, EndPos) 'capture just the data fields

Kannst Du mir nochmal helfen?
Das wäre genial!

DANKE DU BIST KLASSE!


  

Betrifft: AW: Vba Markro für mehrere Dateien ermöglichen von: BENNY
Geschrieben am: 13.01.2010 16:40:19

sorry.. hatte nur einen tipp-fehler! es geht schon, aber ich hätte es gerne vollautomatisch und vor allem untereinander!
Kannst du da nochmal schauen!

Das wäre sooo nettt!!!!


Beiträge aus den Excel-Beispielen zum Thema "Vba Markro für mehrere Dateien ermöglichen"