|
Option Explicit
Public DebugModus As Boolean ' Manuell auf True setzen, wenn du im Einzelschritt arbeitest
Function SpeichereMitVersionskontrolle(pfad As String, basisName As String) As String
Dim i As Integer
Dim dateiPfad As String
i = 1
dateiPfad = pfad & basisName & ".xlsm"
Do While Dir(dateiPfad) <> ""
dateiPfad = pfad & basisName & "_" & i & ".xlsm"
i = i + 1
Loop
SpeichereMitVersionskontrolle = dateiPfad
End Function
Function CSV_Import_Direkt() As Worksheet
On Error GoTo Fehler
Dim suchOrdner As String
Dim dateiPfad As String
Dim neueWB As Workbook
Dim zielWS As Worksheet
Dim csvName As String
Dim dateiName As String
Dim fd As FileDialog
suchOrdner = "R:\1\Kontoauszüge\2025\"
' Datei auswählen
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = suchOrdner
.Title = "Wähle die CSV-Datei aus"
.Filters.Clear
.Filters.Add "CSV-Dateien", "*.csv"
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox "Keine Datei ausgewählt.", vbExclamation
Set fd = Nothing
Exit Function
End If
dateiPfad = .SelectedItems(1)
End With
Set fd = Nothing
Debug.Print "Datei gewählt: " & dateiPfad
dateiName = Dir(dateiPfad)
csvName = Left(dateiName, InStrRev(dateiName, ".") - 1)
' Neue Arbeitsmappe erstellen
Set neueWB = Workbooks.Add
With neueWB.Windows(1)
.Visible = True
.WindowState = xlNormal
.Activate
End With
Set zielWS = neueWB.Sheets(1)
zielWS.Name = "CSV_Tabelle"
zielWS.Activate
zielWS.Range("A1").Select
DoEvents
' Kopfzeilen (außerhalb der Tabelle) einfügen
zielWS.Rows("1:6").Insert Shift:=xlDown
zielWS.Range("E1").Value = "Umsätze VR-Bank"
zielWS.Rows("2:2").RowHeight = 43.5
zielWS.Rows("3:6").RowHeight = 12.75
' CSV einlesen ab Zeile 7
Dim zeile As String, zeilenArray() As String
Dim i As Long, j As Long
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(dateiPfad, 1, True)
i = 7
Do Until ts.AtEndOfStream
zeile = ts.ReadLine
zeilenArray = Split(zeile, ";")
For j = 0 To UBound(zeilenArray)
zielWS.Cells(i, j + 1).Value = zeilenArray(j)
Next j
i = i + 1
Loop
ts.Close
Debug.Print "CSV-Daten bis Zeile: " & i - 1
' Spaltenbreiten manuell setzen
With zielWS
.Columns("A:AQ").ColumnWidth = 12
.Columns("G:G").ColumnWidth = 33
.Columns("K:K").ColumnWidth = 40
End With
' Tabelle ab Zeile 7 erstellen
Dim letzteZeile As Long
letzteZeile = zielWS.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lo As ListObject
Set lo = zielWS.ListObjects.Add(xlSrcRange, zielWS.Range("A7:AQ" & letzteZeile), , xlYes)
lo.Name = "CSV_Tabelle"
lo.TableStyle = "TableStyleMedium2"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Sichtbereich auf die Tabelle setzen
With zielWS
.Activate
.Range("A7").Select
.Parent.Activate
.Parent.Windows(1).ScrollColumn = 1
.Parent.Windows(1).ScrollRow = 1
End With
DoEvents
Debug.Print "Tabelle erstellt: " & lo.Name & " Bereich: " & lo.Range.Address
' Speichern
Dim speicherPfad As String
speicherPfad = SpeichereMitVersionskontrolle(suchOrdner, csvName)
neueWB.SaveAs Filename:=speicherPfad, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Debug.Print "Datei gespeichert unter: " & speicherPfad
' Jetzt erst Spalten ausblenden
On Error Resume Next
zielWS.Columns("A:D").Hidden = True
zielWS.Columns("F:F").Hidden = True
zielWS.Columns("H:J").Hidden = True
zielWS.Columns("M:M").Hidden = True
zielWS.Columns("P:T").Hidden = True
On Error GoTo 0
' Rückgabe
Set CSV_Import_Direkt = zielWS
' Aufräumen
Set fso = Nothing
Set ts = Nothing
Set lo = Nothing
Set zielWS = Nothing
Set neueWB = Nothing
Exit Function
Fehler:
MsgBox "Fehler beim CSV-Import: " & Err.Description, vbCritical
Set CSV_Import_Direkt = Nothing
End Function
Sub Formatierung_Bankauszuege()
On Error GoTo Fehler
Dim ws As Worksheet
Dim letzteZeile As Long
Set ws = CSV_Import_Direkt()
If ws Is Nothing Then
MsgBox "CSV-Import fehlgeschlagen oder abgebrochen.", vbExclamation
Exit Sub
End If
letzteZeile = ws.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
ws.Columns("G").ColumnWidth = 33
ws.Columns("K").ColumnWidth = 40
ws.Columns("E").ColumnWidth = 11
ws.Columns("U:AQ").ColumnWidth = 11
With ws
.Range("L7:N" & letzteZeile).NumberFormat = "#,##0.00;[Red]-#,##0.00"
.Range("U7:AQ" & letzteZeile).NumberFormat = "#,##0.00;[Red]-#,##0.00"
End With
On Error Resume Next
Application.Run "PERSONAL.XLSB!Kontenplan"
Application.Run "PERSONAL.XLSB!Fenster_teilen"
Application.Run "PERSONAL.XLSB!Formeln_Z_4"
Application.Run "PERSONAL.XLSB!Formeln_Z_5"
Application.Run "PERSONAL.XLSB!Formeln_Z_6"
Application.Run "PERSONAL.XLSB!Formelneintrag"
1800 On Error GoTo 0
ws.Range("AZ1").Value = "Formatiert"
MsgBox "Tabelle erstellt bis Spalte AQ, Formatierung abgeschlossen.", vbInformation
Exit Sub
Fehler:
MsgBox "Fehler in Formatierung_Bankauszuege: " & Err.Description, vbCritical
End Sub
die aufzurufende csv-Datei hat 18 Spalten. Die Int.Tabelle wird richtig angelegt (A7 bis AQ132). Sichtbar ist die Tabelle aber nur von O bis AQ. Fehlende Spalten lassen sich nicht einblenden. Wo könnte der Fehler liegen?
|