Problem mit VBA
27.01.2004 12:53:38
Thorsten
Fast fertiges Makro. Ich habe nur folgendes Problem. Ich importiere ANSI Dateien und filter Sie nach einem Kriterium (siehe Code). Er macht das zwar auch aber nur (richtig) bis zu einer bestimmten Anzahl von Dateien. Bei dem Rest, schreibt er mir nicht mehr den Namen der Datei in Feld "G". Das ist aber das wichitgste, damit ich, für mein Beispiel, eine Tour ablesen kann. Ich muss ca. 470 Stück importieren lassen. Ich lade gleich mal eine hoch, damit man sich das vorstellen kann.
Kann das Problem mit der Kapazität von Excel zutun haben? Zeilenbegrenzung oder ähnliches.
Sub TextImport()
Application.DisplayAlerts = False
Dim iRow As Integer, iCol As Integer, i As Integer, k As Integer, l As Integer
Dim sFile As String, sTxt As String, sTour As String
Dim datei As String, j As String
Dim rng As Range
Dim filter As String
filter = InputBox("Filterkriterium:")
If filter = "" Then Exit
Sub 'Makro verlassen wenn kein
'Kriterium angegeben
iRow = 1
iCol = 1
datei = Dir("C:\Test\*.ans")
Do While datei <> ""
sFile = "C:\Test\" + datei
sTour = sFile
sTour = Right(sTour, 9)
On Error Resume Next
Close
Open sFile For Input As #1
Do Until EOF(1)
Line Input #1, sTxt
Do While InStr(sTxt, "|")
Cells(iRow, iCol).Value = Left(sTxt, InStr(sTxt, "|") - 1)
sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, "|"))
iCol = iCol + 1
Loop
Cells(iRow, iCol).Value = sTxt
Cells(iRow, 6).Value = Replace(sTour, ".ans", "")
iRow = iRow + 1
iCol = 1
Loop
Close
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
With Range("A1")
filter = filter + "*"
.AutoFilter Field:=4, Criteria1:=filter
.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Ergebnis").Range("A1")
End With
Sheets("Ergebnis").Range("A:C,E:j").Delete
Sheets("Tabelle1").Range("f:f").Select
Selection.Copy Sheets("Ergebnis").Range("F1")
Sheets("Ergebnis").Range("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
datei = Dir
Sheets("Ergebnis").Cells(1, 1).Value = "M&G Tabelle"
Sheets("Ergebnis").Cells(1, 2).Value = "Name"
Sheets("Ergebnis").Cells(1, 3).Value = "PLZ"
Sheets("Ergebnis").Cells(1, 4).Value = "Ort"
Sheets("Ergebnis").Cells(1, 5).Value = "Diff. km"
Sheets("Ergebnis").Cells(1, 6).Value = "neue Tour"
Sheets("Ergebnis").Columns(3).Insert xlToRight
Sheets("Ergebnis").Cells(1, 3).Value = "Strasse"
Loop
End Sub
Vielleicht weiß jemand Rat.
Gruß Thorsten