AW: komplette Tabelle kopieren
19.05.2005 16:48:15
Lars
Hallo zusammen,
sollte doch auch so funktionieren, oder?
Sub LargeFileImport()
Dim FileName As String
Dim FileNum As Integer
Dim ResultStr As String
Dim wsSheet As Worksheet
Dim strValues(65536, 1) As String
Dim lngRow As Long
Dim intSheet As Integer
Dim intCounter As Integer
FileName = Application.GetOpenFilename("Textdateien (*.txt), *.txt")
If FileName = "" Then End
FileNum = FreeFile()
Open FileName For Input As #FileNum
Application.ScreenUpdating = False
Workbooks.Add template:=xlWorksheet
lngRow = 1
intSheet = 1
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
Do While Seek(FileNum) <= LOF(FileNum)
Line Input #FileNum, ResultStr
If Left(ResultStr, 1) = "=" Then
strValues(lngRow, 1) = "'" & ResultStr
Else
strValues(lngRow, 1) = ResultStr
End If
If lngRow < 65536 Then
lngRow = lngRow + 1
Else
ActiveSheet.Range("A1:A65536") = strValues
ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
lngRow = 1
intSheet = intSheet + 1
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
End If
Loop
Stop
Close
Cells.Select
Selection.NumberFormat = "@"
ActiveSheet.Range("A1:A65536") = strValues
intSheet = 0
For Each wsSheet In ActiveWorkbook.Worksheets
Cells.Select
Selection.NumberFormat = "@"
intSheet = intSheet + 1
Application.StatusBar = "Daten von Blatt " & intSheet & " werden bearbeitet"
With wsSheet
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(10, 2), Array(20, 1), Array(30, 1))
End With
Next wsSheet
Application.ScreenUpdating = True
Application.StatusBar = "Fertig"
End Sub
Mit freudlich Füßen
Lars