Das Problem ist schon mal gelöst gewesen für eine andere Datei aber ich kann es nicht auf diese übertragen, und in der anderen Datei kann ich nicht rumschreiben...
Private Sub ExportCopy()
Set objWS = CreateObject("WScript.Shell")
strDesktopPath = objWS.SpecialFolders("Desktop")
saveLocation = strDesktopPath & "\Export\" '//Change as required, make sure you have a trailing "\"
Kunde = Range("Kunde").Value
Auftrag = Range("Auftrag").Value
saveFile = saveLocation & "Datentabelle_" & Kunde & "_" & Auftrag & ".xlsm"
If Dir(saveFile) = "" Then
ActiveWorkbook.SaveCopyAs saveFile
Else
ActiveWorkbook.SaveAs saveFile
End If
End Sub
Sub ExportButton()
Sortieren
ExportCopy
'Definiere Bereich zum exportieren
infoRow = 9
zeilestart = infoRow + 1
Auftrag = Range("Auftrag").Value
'spaltestart = 2
'spaltestopp = 27
'Range(Cells(zeilestart, spaltestart), Cells(zeilestopp, spaltestopp)).Activate
'Cells(zeilestart, 1).Activate
Range("SORT_START").Activate
Dim FF As Integer
Dim wLine As String
Dim saveLocation As String
Dim cID As String
Dim lRow As Long
Set objWS = CreateObject("WScript.Shell")
strDesktopPath = objWS.SpecialFolders("Desktop")
saveLocation = strDesktopPath & "\Export\" '//Change as required, make sure you have a trailing "\"
'Erstelle Ordner, falls nicht vorhanden
If Dir(saveLocation, vbDirectory) = vbNullString Then
MkDir saveLocation
MsgBox "Created folder " & saveLocation
End If
Do
FF = FreeFile
cID = ActiveCell.Value
Open saveLocation & cID & "__" & Auftrag & ".csv" For Output As #FF
Print #FF, Cells(infoRow, 1) & "," & Cells(infoRow, 3) & "," & Cells(infoRow, 4) & "," & Cells(infoRow, 5) & "," & Cells(infoRow, 6) & "," & Cells(infoRow, 7) & "," & Cells(infoRow, 8) & "," & Cells(infoRow, 9) & "," & Cells(infoRow, 10) & "," & Cells(infoRow, 11) & "," & Cells(infoRow, 12) & "," & Cells(infoRow, 13) & "," & Cells(infoRow, 14) & "," & Cells(infoRow, 15) & "," & Cells(infoRow, 16) & "," & Cells(infoRow, 17) & "," & Cells(infoRow, 18) & "," & Cells(infoRow, 19) & "," & Cells(infoRow, 20) & "," & Cells(infoRow, 21) & "," & Cells(infoRow, 22) & "," & Cells(infoRow, 23) & "," & Cells(infoRow, 24) & "," & Cells(infoRow, 25) & "," & Cells(infoRow, 26) & "," & Cells(infoRow, 27) & "," & Cells(infoRow, 28) & "," & Cells(infoRow, 29)
While ActiveCell.Value = cID
lRow = ActiveCell.Row
Dim cell23 As String
cell27 = Cells(lRow, 27)
cell27 = RemoveChars(cell27, ".,!?:/\\")
Dim cell29 As String
cell29 = Cells(lRow, 29)
cell29 = RemoveChars(cell29, ".,!?:/\\")
Print #FF, Cells(lRow, 1) & "," & Cells(lRow, 3) & "," & Cells(lRow, 4) & "," & Cells(lRow, 5) & "," & Cells(lRow, 6) & "," & Cells(lRow, 7) & "," & Cells(lRow, 8) & "," & Cells(lRow, 9) & "," & Cells(lRow, 10) & "," & Cells(lRow, 11) & "," & Cells(lRow, 12) & "," & Cells(lRow, 13) & "," & Cells(lRow, 14) & "," & Cells(lRow, 15) & "," & Cells(lRow, 16) & "," & Cells(lRow, 17) & "," & Cells(lRow, 18) & "," & Cells(lRow, 19) & "," & Cells(lRow, 20) & "," & Cells(lRow, 21) & "," & Cells(lRow, 22) & "," & Cells(lRow, 23) & "," & Cells(lRow, 24) & "," & Cells(lRow, 25) & "," & Cells(lRow, 26) & "," & cell27 & "," & Cells(lRow, 28) & "," & cell29
ActiveCell.Offset(1, 0).Activate
Wend
Close #FF
Name saveLocation & cID & "__" & Auftrag & ".csv" As saveLocation & cID & "__" & Auftrag & ".csv"
'Loop Until ActiveCell.Row > Range("ExportSTOPP").Value
Loop Until ActiveCell.Value = ""
Cells(10, 1).Activate
Call Shell("explorer.exe" & " " & saveLocation, vbNormalFocus)
MsgBox "Erstellte Excel-Datei bitte in Kundenordner verschieben"
Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
End Sub
Sub Sortieren()
With ActiveSheet.Sort
.SortFields.Add Key:=Range("A9"), Order:=xlAscending
.SortFields.Add Key:=Range("B9"), Order:=xlAscending
.SortFields.Add Key:=Range("C9"), Order:=xlAscending
.SortFields.Add Key:=Range("D9"), Order:=xlAscending
.SetRange Range("A9:AA1000")
.Header = xlYes
.Apply
End With
Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
End Sub
' beliebige Zeichen entfernen / ersetzen
Public Function RemoveChars(ByVal Source As String, ByVal Chars As String, _
Optional ByVal ReplaceWith As String = "") As String
' RegExp via Late-Bindung instanzieren
Dim oRegExp As Object ' RegExp
Set oRegExp = CreateObject("VBScript.RegExp")
With oRegExp
.IgnoreCase = True
.Global = True
.MultiLine = True
.Pattern = "[\" & Chars & "]"
' alle nicht zulässigen Zeichen ersetzen
RemoveChars = .Replace(Source, ReplaceWith)
End With
Set oRegExp = Nothing
End Function
Und der Code ist schlecht kommentiert und überhaupt nicht aufgeräumt...