AW: Alle *.csv-Dateien eines Ordners aktualisieren
16.05.2013 09:26:56
Johannes
Hallo,
ich habs grad mal probiert und die Zeile in meinem bestehenden Code ersetzt, leider führt das zur Felermeldung: Laufzeitfehler '438' - Objekt unterstützt diese Methode oder Eigenschft nicht.
Allerdings habe ich den Code mit zusammgestückelten Code-Fragmenten aus dem weiten Netz so hinbekommen, dass es einigermaßen läuft (man kann sich ja nie sicher sein). Dabei wird jetzt jedes Sheet der Reihe nach aktiviert und geschaut, wieviele Zeilen und Spalten genutzt werden und demnach dann gespeichert. Jetzt scheint es auch keine Probleme mehr mit leeren Tabellenblättern zu geben.
Hier mal der aufwendigere Code mit noch einpaar auskommentierten "Testzeilen". Zusätzlich ist jetzt eine überdimensionierte Variante einer Funktion drin, die die letzten benutzten Spalten und Zeilen ausspuckt. Ich weiß auch nicht, ob da redundante oder überflüssige Zeilen drin sind, da ich den Code auch nicht zur Gänze verstanden hab.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wks As Worksheet
Dim nummer As Integer
nummer = 0
For Each wks In Worksheets
nummer = nummer + 1
prcCreateCSV wks, nummer
Next
End Sub
Public Sub prcCreateCSV(wks As Worksheet, nummer As Integer)
Dim intFileNumber As Integer
Dim lngRow As Long
Dim vntArray As Variant
Dim intItem As Integer
Dim strText As String
Dim strText2 As String
Dim i, j, LastRow, LastColumn As Integer
Const strSep As String = ";"
Dim rng As Range
'Set wks = ActiveWorkbook.Worksheets(nummer)
With wks.Cells(1, 1).CurrentRegion
'With wks.Cells(1, 1).UsedRange
Sheets(nummer).Activate
Set rng = Sheets(nummer).Cells
'i = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'j = ActiveSheet.UsedRange.Columns.Count
LastRow = Last(1, rng)
LastColumn = Last(2, rng)
strText2 = ActiveSheet.CodeName
'If i > 0 Then
For lngRow = 1 To LastRow
'vntArray = .Cells(lngRow, 1).Resize(, ActiveSheet.UsedRange.Columns.Count)
vntArray = .Cells(lngRow, 1).Resize(, LastColumn)
vntArray = WorksheetFunction.Transpose(WorksheetFunction.Transpose(vntArray))
If strText = "" Then
strText = Join(vntArray, strSep)
Else
strText = strText _
& vbCrLf _
& IIf(lngRow = LastRow, Join(vntArray, ";"), Join(vntArray, strSep))
'& IIf(lngRow = .Rows.Count, Join(vntArray, ";"), Join(vntArray, strSep))
End If
Next
'End If
End With
intFileNumber = FreeFile
With wks
Open .Parent.Path & "\" & .Name & ".csv" For Output As #intFileNumber
End With
Print #intFileNumber, strText
Close #intFileNumber
End Sub
Function Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Long
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
Vielen Dank für den Denkanstoß, vielleicht hilfts ja auch jemand anderem.
mfg