Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
428to432
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
428to432
428to432
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA muss noch was anders!!!

VBA muss noch was anders!!!
16.05.2004 14:49:01
Martin
HAllo!
Ich hab ein Code:

Sub LargeFileImport()
'Bernie Deitrick's code for opening vary large text files in Excel
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
'Ask User for File's Name
FileName = Application.GetOpenFilename
'Check for no entry
If FileName = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileName For Input As #FileNum
'Turn Screen Updating Off
Application.ScreenUpdating = False
'Create A New WorkBook With One Worksheet In It
Workbooks.Add Template:=xlWorksheet
'Set The Counter to 1
Counter = 1
'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr
'Store Variable Data Into Active Cell
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "" & ResultStr
Else
ActiveCell.Value = ResultStr
End If
If ActiveCell.Row = 65536 Then
'If On The Last Row Then Add A New Sheet
ActiveWorkbook.Sheets.Add
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If
'Increment the Counter By 1
Counter = Counter + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
'Remove Message From Status Bar
Application.StatusBar = False
End Sub

Der macht aber Tabellen wo die Zelleninhalte mit " eingefasst werden und durch , getrennt werden. So kann ich mit den Daten nichts anfangen. Ich will die wieder in Excel öffnen und weiter bearbeiten.
Kann das jemand so ändern das ich die Daten die der Code ausgibt auch in Excel also mit spalten anzeigen kann.
DANKE!!!!!!!!!!!!!!!
MFG
M.Schnuchel

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA muss noch was anders!!!
16.05.2004 15:51:55
Andre
Hallo Martin,
Versuch mal das!
Den Code in ein Modul kopieren und read_raw_data einem Button zuweisen.
Viele Grüße
André
Option Explicit
Public wbTarget As Workbook
Public wsTarget As Worksheet

Sub read_raw_data()
Dim FName
Dim posY As Long
Dim trenner As Integer
FName = Application.GetOpenFilename("Textdateien (*.txt), *.txt")
If FName = False Then
Exit Sub
End If
Open FName For Binary As #1
make_target
posY = 1
trenner = 44 'Trennzeichen = Komma
Do While Not EOF(1)
read_oneline 1, posY, trenner
posY = posY + 1
If posY > 65536 Then 'Anzahl der Zeilen nachdem ein neues Blatt angelegt werden soll
posY = 1
make_new_target
End If
Loop
Close #1
End Sub


Sub read_oneline(x As Long, y As Long, trenner As Integer)
Dim zeichenfolge, zeichen As String
Do While Not EOF(1)
zeichen = Input(1, #1)
Select Case zeichen
'    Case Is = Chr(32)   'Leerzeichen unterdrücken
Case Is = Chr(34)   '" unterdrücken
Case Is = Chr(13)   'Ende der Zeile
wsTarget.Cells(y, x).Value = zeichenfolge
zeichenfolge = ""
zeichen = Input(1, #1)
Exit Sub
Case Is = Chr(trenner)    'Trennzeichen
wsTarget.Cells(y, x).Value = zeichenfolge
zeichenfolge = ""
x = x + 1
Case Else
zeichenfolge = zeichenfolge & zeichen
End Select
Loop
If zeichenfolge <> "" Then
wsTarget.Cells(y, x).Value = zeichenfolge
End If
End Sub


Sub make_target()
Set wbTarget = Workbooks.Add(xlWBATWorksheet)
If (wbTarget Is Nothing) Then
Call MsgBox("Konnte kein Arbeitsblatt für die Ergebnisse anlegen!", vbCritical + vbOKOnly, "Fehler!")
Exit Sub
End If
Set wsTarget = wbTarget.Worksheets(1)
wsTarget.Name = "data" & wbTarget.Worksheets.Count
If (wsTarget Is Nothing) Then
Call MsgBox("Konnte kein Arbeitsblatt für die Ergebnisse anlegen!", vbCritical + vbOKOnly, "Fehler!")
Exit Sub
End If
End Sub


Sub make_new_target()
Set wsTarget = wbTarget.Worksheets.Add(after:=wbTarget.Worksheets(wbTarget.Worksheets.Count))
wsTarget.Name = "data" & wbTarget.Worksheets.Count
If (wsTarget Is Nothing) Then
Call MsgBox("Konnte kein Arbeitsblatt für die Ergebnisse anlegen!", vbCritical + vbOKOnly, "Fehler!")
Exit Sub
End If
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige