Hallo Lucas,
ich habe da mal aus ein paar gesammelten Werken etwas
neues gebaut. Du kannst entweder die Daten über die Zwischenablage einfügen (benötift einen Verweis auf MS Forms) oder aber die Daten Zelle für Zelle einfügen,
ist aber langsamer.
Hier mal das Coding.
Gruß
Nico
Option Explicit
Private Declare Function GetTickCount Lib „Kernel32“ () As Long
Sub ImportCSV()
Dim strTitel As String
Dim strPfad As String
Dim strDatei As String
Dim colDateien As Collection
Dim intCounter As Integer
Dim strData As String
Dim bolCopyPaste As Boolean
Dim varData() As Variant
Dim lngZeile As Long
Dim intSpalte As Integer
Dim strTrennzeichen As String
Dim bolTextzeichen As Boolean
On Error GoTo FEHLER
strTrennzeichen = vbTab
strTitel = „Import CSV:“
If MsgBox(„Copy and Paste Methode verwenden?“, vbQuestion + vbYesNo, strTitel) = vbYes Then
bolCopyPaste = True
Else
bolCopyPaste = False
If MsgBox(„Textbegrenzung (“") löschen?", vbQuestion + vbYesNo, strTitel) = vbYes Then
bolTextzeichen = True
Else
bolTextzeichen = False
End If
End If
EINGABE_PFAD:
strPfad = InputBox(„Bitte Pfad eingeben:“, strTitel, ThisWorkbook.Path)
If StrPtr(strPfad) = 0 Then
'Abbrechen gedrückt
GoTo ENDE
ElseIf strPfad = „“ Then
'kein Pfad angegeben
MsgBox „Bitte einen Pfad eingeben oder Schaltfläche ‚Abbrechen‘ verwenden!“, vbExclamation, strTitel
GoTo EINGABE_PFAD
End If
If Not Right(strPfad, 1) = „“ Then
strPfad = strPfad & „“
End If
‚Pfad vorhanden
If DirExists(strPfad) = False Then
MsgBox „Verzeichnis '“ & strPfad & "‘ unbekannt!", vbCritical, strTitel
GoTo EINGABE_PFAD
End If
EINGABE_DATEI:
strDatei = InputBox(„Bitte Dateinamen eingeben:“, strTitel, „*.csv“)
If StrPtr(strDatei) = 0 Then
'Abbrechen gedrückt
GoTo ENDE
ElseIf strDatei = „“ Then
'kein Pfad angegeben
MsgBox „Bitte einen Dateinamen eingeben oder Schaltfläche ‚Abbrechen‘ verwenden!“, vbExclamation, strTitel
GoTo EINGABE_DATEI
End If
‚passende Dateien im Verzeichnis?
If Dir(strPfad & strDatei) = „“ Then
If MsgBox(„Im Verzeichnis '“ & strPfad & "‘ wurden keine Dateien gefunden!", vbCritical + vbRetryCancel, strTitel) = vbRetry Then
GoTo EINGABE_DATEI
Else
GoTo ENDE
End If
End If
'alle Dateinamen in Collection ablegen
Set colDateien = New Collection
strDatei = Dir$(strPfad & strDatei)
Do Until strDatei = „“
colDateien.Add strDatei
strDatei = Dir$
Loop
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For intCounter = 1 To colDateien.Count
ThisWorkbook.Worksheets.Add
ActiveSheet.Name = „6“ & colDateien(intCounter)
ActiveSheet.Range(„A1“).Select
Application.StatusBar = "Import von " & colDateien(intCounter) & „…“
If bolCopyPaste = True Then
strData = ReadFile(strPfad & colDateien(intCounter))
strData = Replace(strData, strTrennzeichen, vbTab)
ClipBoardSetText strData
ActiveSheet.Paste
Else
varData = GetDataArray(strPfad & colDateien(intCounter), strTrennzeichen)
For lngZeile = 0 To UBound(varData, 2)
Application.StatusBar = "Import von " & colDateien(intCounter) & " / Zeile " & lngZeile & " von " & UBound(varData, 2) & „…“
For intSpalte = 0 To UBound(varData, 1)
If bolTextzeichen = True Then
If Left(varData(intSpalte, lngZeile), 1) = „“"" And Right(varData(intSpalte, lngZeile), 1) = „“"" Then
varData(intSpalte, lngZeile) = Mid(varData(intSpalte, lngZeile), 2, Len(varData(intSpalte, lngZeile)) - 2)
End If
End If
ActiveCell.Offset(lngZeile, intSpalte).Value = varData(intSpalte, lngZeile)
Next intSpalte
Next lngZeile
End If
ActiveSheet.Range(„A1“).Select
Next
ENDE:
Application.StatusBar = „“
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set colDateien = Nothing
Exit Sub
FEHLER:
If Err.Number = 1004 Then
'Pause wg. Fehler bein Einfügen…
Delay 2
Resume
Else
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, strTitel
GoTo ENDE
End If
End Sub
Private Function DirExists(Path As String) As Boolean
On Error Resume Next
DirExists = CBool(GetAttr(Path) And vbDirectory)
On Error GoTo 0
End Function
Private Function FileExists(Path As String) As Boolean
Const NotFile = vbDirectory Or vbVolume
On Error Resume Next
FileExists = (GetAttr(Path) And NotFile) = 0
On Error GoTo 0
End Function
Private Function ReadFile(ByRef Path As String) As String
Dim FileNr As Long
'Falls nicht vorhanden, nichts zurückgeben:
On Error Resume Next
If FileLen(Path) = 0 Then Exit Function
On Error GoTo 0
'Datei einlesen:
FileNr = FreeFile
Open Path For Binary As #FileNr
ReadFile = Space$(LOF(FileNr))
Get #FileNr, , ReadFile
Close #FileNr
End Function
Function ClipBoardSetText(TextIn As String) As Boolean
'Benötigt einen Verweis auf die Microsoft Forms 2.0 Object Library.
'Dafür einfach ein UserForm erstellen und wieder löschen.
Dim objData As DataObject
On Error GoTo FEHLER
Set objData = New DataObject
With objData
.SetText TextIn
.PutInClipboard
End With
Set objData = Nothing
ClipBoardSetText = True
Exit Function
FEHLER:
Set objData = Nothing
ClipBoardSetText = False
End Function
Function GetDataArray(Datei As String, Optional Trennzeichen As String = „;“) As Variant
Dim intFreeFile As Integer
Dim varTempTabelle As Variant
Dim strTempString As String
Dim intSpalten As Integer
Dim lngZeilen As Long
Dim intCounter As Integer
Dim varData() As Variant
strTempString = ReadLine(Datei, 1)
varTempTabelle = Split(strTempString, Trennzeichen)
intSpalten = UBound(varTempTabelle, 1)
ReDim varData(intSpalten, lngZeilen)
lngZeilen = 0
For lngZeilen = 1 To FileLineCount(Datei)
strTempString = ReadLine(Datei, lngZeilen)
If strTempString „“ Then
ReDim Preserve varData(intSpalten, lngZeilen - 1)
varTempTabelle = Split(strTempString, Trennzeichen)
For intCounter = 0 To intSpalten - 1
varData(intCounter, lngZeilen - 1) = varTempTabelle(intCounter)
Next intCounter
End If
Next lngZeilen
GetDataArray = varData()
End Function
Public Function ReadLine(ByVal sFile As String, _
ByVal nLine As Long) As String
Dim sLines() As String
Dim ofso As Object
Dim oFile As Object
’ Verweis auf das FileSystemObject erstellen
Set ofso = CreateObject(„Scripting.FileSystemObject“)
’ Existiert die Datei überhaupt?
If ofso.FileExists(sFile) Then
’ Datei öffnen
Set oFile = ofso.OpenTextFile(sFile)
’ Alles lesen und in Array zerlegen
sLines = Split(oFile.ReadAll, vbCrLf)
’ Datei schließen
oFile.Close
ReadLine = sLines(nLine - 1)
End If
End Function
Public Function FileLineCount(ByVal sFile As String) As Long
Dim F As Integer
Dim nCount As Long
Dim sBuffer As String
Dim nFilePos As Long
Dim nSize As Long
Dim nBytes As Long
Dim nPos As Long
’ Blockgröße
Const nBlockSize = 16384
’ Datei im Binary-Mode öffnen
F = FreeFile
Open sFile For Binary As #F
’ Datei blockweise auslesen
nSize = LOF(F)
nFilePos = 0
Do While nFilePos nSize Then nBytes = nSize - nFilePos
’ Inhalt lesen
sBuffer = Space$(nBytes)
Get #F, , sBuffer
’ Zeilenumbrüche zählen
nPos = 0
Do
nPos = InStr(nPos + 1, sBuffer, Chr$(13))
If nPos > 0 Then nCount = nCount + 1
Loop Until nPos = 0
nFilePos = nFilePos + nBytes
Loop
Close #F
FileLineCount = nCount
End Function
Private Sub Delay(Sekunden As Long)
Dim lngTimeOut As Long
lngTimeOut = (GetTickCount / 1000) + Sekunden
Do
DoEvents
Loop Until lngTimeOut
da ich leider so gut wie keine Ahnung von VB habe.