AW: Fehler bei CSV Import
05.06.2016 20:24:17
Michael
Hi zusammen,
@Fennek: der 4. Weg ist im Prinzip, den Text als String zeilenweise oder in einem "Riesenstring" am Stück einzulesen (zur Info auskommentiert im Code skizziert).
@alle:
Allerdings hatte ich bei DIESER csv dann irgendwann keine Lust mehr, da sie "byteweise programmiert" so was von widerspenstig ist: ein split nach "," geht natürlich nicht, wenn "," teilweise in Zahlenwerten vorkommt, und leider ist die csv *nicht* (wie im Prozedurkopf erwähnt) mit ";", sondern eben mit "," getrennt).
Auch nach erfolgreichem Import mit Deinem Codeschnipsel gibt es noch Einiges nachzubearbeiten, nämlich diese elenden chr(160) vor dem % bzw. rauswerfen usw.
Hier alles am Stück:
Option Explicit
Public intCalculation As Integer
Sub SpaltenBearbeiten()
Dim wie() As Variant
Dim i&, r As Range, zMax&, j&, k&, erste&
Dim a As Variant
Application.Calculation = xlCalculationAutomatic
ReDim wie(1 To 3, 1 To 5)
wie(1, 1) = "B": wie(1, 2) = ".": wie(1, 3) = "": wie(1, 4) = 2: wie(1, 5) = 1
wie(2, 1) = "F": wie(2, 2) = Chr(160) & "%": wie(2, 3) = "": wie(2, 4) = 2: wie(2, 5) = 0.01
wie(3, 1) = "H": wie(3, 2) = Chr(160) & "": wie(3, 3) = "": wie(3, 4) = 1: wie(3, 5) = 1
For i = 2 To 3 'Spalten B/C sind bereits "automatisch" Zahlen
zMax = Range(wie(i, 1) & Rows.Count).End(xlUp).Row
Range(wie(i, 1) & 1).Resize(zMax, wie(i, 4)).Replace wie(i, 2), wie(i, 3)
' führt leider zu unschönen Nullen ...
' Range("xy1") = wie(i, 5): Range("xy1").Copy
' Range(wie(i, 1) & 1).Resize(zMax, wie(i, 4)).PasteSpecial _
' Paste:=xlPasteAll, Operation:=xlMultiply
' Range("xy1") = Empty
Set r = Range(wie(i, 1) & 1).Resize(zMax, wie(i, 4))
a = r
For j = 1 To UBound(a)
For k = 1 To wie(i, 4)
If Len(a(j, k)) Then
If IsNumeric(a(j, k)) Then
a(j, k) = a(j, k) * wie(i, 5)
If erste = 0 Then erste = j
End If
End If
Next
Next
' geht komischerweise nicht, wegen des resize mit array-Wert?!
' Range(wie(i, 1) & 1).Resize(zMax, wie(i, 4)) = a
' Range(wie(i, 1) & 1 & ":" & wie(i, 1) & zMax).Resize(, wie(i, 4)) = a
' dann eben mit gesetzter range-Variable r
r = a
If Right(wie(i, 2), 1) = "%" Then r.Offset(erste - 1).NumberFormat = "0.00 %"
If Right(wie(i, 2), 1) = "" Then r.Offset(erste - 1).NumberFormat = _
"_-* #,##0.00 [$-407]_-;-* #,##0.00 [$-407]_-;_-* ""-""? [$-407]_-;_-@_-"
Next
'und zu guter Letzt noch das Datum als echtes Excel-Datum:
zMax = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & zMax).Value = DateValue(Range("A" & zMax).Text)
End Sub
Sub CSV2XLS()
'Alle .csv (Trennzeichen ;) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim tmpName As String
Dim tarName As String
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, wks As Worksheet, iFree As Integer
With Application.FileDialog(4)
.AllowMultiSelect = True
.InitialFileName = "c:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
' On Error GoTo FEHLER
DoEvents
' GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.GetFolder(strFolder)
' 'Das gehört sich IN die Schleife...
' iFree = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.csv" Then
' tmpName = oFile.Name
' tarName = Right(tmpName, 21)
' ' Die nächste Anweisung geht so nicht
' ' (weil der Name bei mir kleiner ist als 21 Zeichen)
' ' Aber:
' ' Während man eine Verzeichnisstruktur durchläuft,
' ' sollte man besser nichts an den Namen ändern:
' ' DAS würde ich in einem getrennten Lauf machen.
' oFile.Name = tarName
Set wks = Worksheets.Add
wks.Name = oFile.Name
' lngL = 1
' ' Dieser Code ist bei DIESER Dateistruktur nicht sinnvoll anwendbar,
' ' da die Datei keine passenden "Zeilentrenner" (CrLf=chr(13)&chr(10)) enthält.
' Open oFile For Input As iFree
' Do Until EOF(iFree)
' Line Input #iFree, strTxt
' myArr = Split(strTxt, ",")
' With wks
' .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
' End With
' lngL = lngL + 1
' Loop
' Close #iFree
' ' Die Alternative wäre eine zusätzliche Stringvariable s und das Einlesen
' ' in einem Rutsch:
' s = String(FileLen(Datei), 0)
' iFree = FreeFile
' Open oFile For Binary Access Read As #1
' Get iFree, , s
' Close #iFree
' ZeilenArr = Split(s, vbLf) ' eben nicht vbCrLf
' 'usw.
' Hier analog zu Fenneks aufgezeichnetem Code unter W7/XL2013
Workbooks.OpenText Filename:=strFolder & "\" & oFile.Name, Origin:=65001, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True _
, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
ActiveSheet.UsedRange.Copy wks.Range("A1")
ActiveWorkbook.Close savechanges:=False
SpaltenBearbeiten
End If
Next oFile
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub
(Das getmorspeed und on error habe ich zum Entwickeln auskommentiert)
Als ganze Datei mit noch ein paar Hinweisen: https://www.herber.de/bbs/user/106004.xlsm
@Fennek: ich habe Deinen kürzlichen Hinweis von wegen Gefahren beim Download von "xlsm" im Hinterkopf...
Sag, sollte es nicht reichen, "immer" eine "Herber"-Datei geöffnet zu haben, von der aus man die runtergeladene Datei öffnet, und zwar mit appl.enableevents=false, readonly=true usw., dann werden evtl. event-gesteuerte Makros nicht ausgeführt, und man kann in aller Ruhe erst mal den Code überfliegen.
Ein netter Nebeneffekt wäre, daß man interessante Dateien dann gleich in einer Liste fortschreiben und evlt. mit Kommentaren, Forumslink oder Stichwörtern versehen könnte.
Happy Exceling,
Michael