.xls zu .csv Datei, Speicherort festlegen
30.08.2016 10:26:23
John
in diesem Makro werden Daten aus einer .xlsm Datei (Berechnungsblatt 44 - Freigrenze M017.xlsm) in eine .xls Dateo (Meldung Lohnverst. Jan. 2016.xls) weitergeben und dann im Anschluss daraus eine .csv Datei (Meldung Lohnverst. Jan. 2016.csv) erstellt. Diese soll dann als Mail versendet werden.
Klingt erst mal etwas umständlich... aber es funktioniert soweit alles... bis auf:
Momentan speichert er die .csv Datei in dem gleichen Ordner, wo die ursprüngliche .xlsm Datei liegt.
Kann mir jmd. sagen, wie & wo ich hier einbauen kann, dass er die .csv Datei in einen bestimmten Pfad & Ordner ablegt? (fett markierte ist der Part, wo er die .csv erstellt)
VIELEN DANK!
Sub Test()
Dim zaehler As Integer 'Variablen-Definitionen
Dim meineZahl As Integer
Dim n As Long
Dim Bukr As String
zaehler = 0
meineZahl = 700
n = 2
Bukr = Range("C4")
Application.ScreenUpdating = False 'Bildschirmaktualisierung - _
deaktiviert
ChDrive "Z:\"
Workbooks.Add 'Erstellt neue .xls Datei
ActiveWorkbook.SaveAs "Z:\Neuer Ordner\Meldung Lohnverst. Jan. 2016.xls"
Range("B1").Select 'Ab hier wird Zeile 1 mit den _
_
jeweiligen Überschriften beschriftet
ActiveCell.FormulaR1C1 = "Buchungskreis (L, 4)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Geschäftsbereich (L, 4)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Belegdatum (R, 10)"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Belegart (R, 2)"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Buchungsdatum (R, 10)"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Buchungsperide (R, 2)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Währung (L, 5)"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Soll-Konto (L, 10) 6-stellig"
Range("J1").Select
ActiveCell.FormulaR1C1 = "BWA für Soll-Konto"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Kst.Soll-Kto. (L, 10)"
Range("L1").Select
ActiveCell.FormulaR1C1 = "USt-Kz.Soll-Kto. (L, 2)"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Haben-Konto (L, 10) 6-stellig"
Range("N1").Select
ActiveCell.FormulaR1C1 = "BWA für Haben-Konto"
Range("O1").Select
ActiveCell.FormulaR1C1 = "Kst.Haben-Kto. (L, 10)"
Range("P1").Select
ActiveCell.FormulaR1C1 = "USt-Kz.Haben-Kto. (L, 2)"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "Buchungsbetrag (R, 14)"
Range("R1").Select
ActiveCell.FormulaR1C1 = "Zuordnungsnummer (L, 18)"
Range("S1").Select
ActiveCell.FormulaR1C1 = "Buchungstext (L, 50)"
Range("A1:S1").Select 'Zeile 1 (A bis S) wird ausgewä _
_
hlt
With Selection 'und formatiert: Text vertikal _
_
gedreht
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Workbooks("Berechnungsblatt 44 - Freigrenze M017.xlsm").Sheets("Januar").Activate
Range("E14").Select
Do While meineZahl > 9 'Bedingungsschleife
meineZahl = meineZahl - 1
zaehler = zaehler + 1
If ActiveCell.Value = "nicht nötig" Then 'Wenn die aktive Zelle leer ist, _
_
dann
ActiveCell.Offset(1, 0).Select 'spring eine Zelle runter
Else 'Ansonsten
ActiveCell = Date 'Füge aktuelle Datum ein
ActiveCell.Offset(0, -2).Select 'Spring 2 Zellen nach links
Selection.Copy 'Kopieren
Workbooks("Meldung Lohnverst. Jan. 2016.xls").Sheets("Tabelle1").Activate
Range("Q" & n).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'Einfügen in Spalte Q des _
kopierten Wertes
Range("B" & n).Select 'Einfügen des Buchungskreises _
_
in Spalte B
ActiveCell.FormulaR1C1 = Bukr
Range("D" & n).Select 'Einfügen des Datums in Spalte _
_
D
ActiveCell = Date
Range("E" & n).Select 'Einfügen der Belegart in _
Spalte E
ActiveCell.FormulaR1C1 = "TS"
Range("H" & n).Select 'Einfügen der Währung in Spalte _
_
H
ActiveCell.FormulaR1C1 = "EUR"
Range("R" & n).Select 'Einfügen des aktuellen Jahres _
_
in Spalte R
ActiveCell = Year(Date)
Range("S" & n).Select 'Einfügen des Buchungstextes
ActiveCell.FormulaR1C1 = "Manuelle Lohnversteuerung " & Month(Date) & "/" & Year(Date)
n = n + 1 'n = n (2) + 1 = 3
Workbooks("Berechnungsblatt 44 - Freigrenze M017.xlsm").Sheets("Januar").Activate
ActiveCell.Offset(1, 2).Select 'Springt eine Zelle nach unten _
_
und zwei nach rechts
End If
Loop
Workbooks("Meldung Lohnverst. Jan. 2016.xls").Sheets("Tabelle1").Activate
Columns("A:S").Select 'Spalte A bis S ausgewählt und _
_
dann
Columns("A:S").EntireColumn.AutoFit 'Spaltenbreite angepasst
'_________________________________________________________________________________________
Dim beldat As String
Dim belart As String
Dim bukrs As String
Dim budat As String
Dim periode As String
Dim waehrung As String
Dim referenz As String
Dim kopfzeile As String
Dim zeile1 As String
Dim zeile2 As String
Dim kos As String
Dim koh As String
Dim sts As String
Dim sth As String
Dim ksts As String
Dim ksth As String
Dim bwas As String
Dim bwah As String
Dim betrag As String
Dim zuord As String
Dim postext As String
Dim header As String
Dim strech As String
Dim namecsv As String
buschs = "40"
buschh = "50"
strech = "X"
' !. Zeile in CSV-Datei definieren
header = "Belegdatum;Belegart;Buch.kreis;Buch.datum;Buch.periode;Währung;"
header = header & "Referenz;Buch.schl.;Konto;Betrag;Steuerkennz.;Kostenstelle;"
header = header & "Zuordnung;Text;Steuer rechnen;Zlg.bedingung;Zahlsperre;"
header = header & "BWA LC-AA / RSt;PG;SHB;Zahlweg;Basisdatum;Barcode"
pfad = ActiveWorkbook.Path
Name = ActiveWorkbook.Name
namecsv = "Meldung Lohnverst. Jan. 2016.csv"
Open namecsv For Output As #1
Print #1, header
i = 2 'Zähler Usprungsdatei
' Quellsheet verarbeiten
Do While Cells(i, 2) ""
beldat = ""
belart = ""
bukrs = ""
budat = ""
periode = ""
waehrung = ""
referenz = ""
kopfzeile = ""
zeile1 = ""
zeile2 = ""
kos = ""
koh = ""
sts = ""
sth = ""
ksts = ""
ksth = ""
bwas = ""
bwah = ""
betrag = ""
zuord = ""
postext = ""
' Einzelwerte einlesen
If Cells(i, 1) = "" Then ' Wenn Wert = X soll die Zeile nicht verarbeitet werden
beldat = Cells(i, 4)
Do While InStr(beldat, ".") 0 'Aus Belegdatum die Punkte entfernen
beldat = Left(beldat, InStr(beldat, ".") - 1) & Right(beldat, (Len(beldat) - InStr( _
_
beldat, ".")))
Loop
belart = Cells(i, 5)
bukrs = Cells(i, 2)
budat = Cells(i, 6)
Do While InStr(budat, ".") 0 'Aus Buchungsdatum die Punkte entfernen
budat = Left(budat, InStr(budat, ".") - 1) & Right(budat, (Len(budat) - InStr(budat, _
_
".")))
Loop
periode = Cells(i, 7)
waehrung = Cells(i, 8)
referenz = ""
kopfzeile = beldat & ";" & belart & ";" & bukrs & ";" & budat & ";" & periode & ";" & _
_
waehrung & ";" & referenz & ";"
kos = Cells(i, 9)
koh = Cells(i, 13)
sts = Cells(i, 12)
sth = Cells(i, 16)
' Kostenstelle zusammensetzen
If Cells(i, 11) "" Then
ksts = bukrs & Cells(i, 11)
End If
If Cells(i, 15) "" Then
ksth = bukrs & Cells(i, 15)
End If
bwas = Cells(i, 10)
bwah = Cells(i, 14)
betrag = Cells(i, 17)
zuord = Left(Cells(i, 18), 18)
postext = Left(Cells(i, 19), 50)
zeile1 = buschs & ";" & kos & ";" & betrag & ";" & sts
' Erzeugen zeilen in CSV-Datei
' Wenn Steuerkennzeichen = V0, dann nicht Steuer rechnen aktivieren
' Wenn Steuerkennzeichen V0 und beide Steuerkennzeichen sind gleich, dann auch
' Steuer rechnen nicht archivieren
If sts "V0" Then
If sts = sth Then
zeile1 = zeile1 & ";" & ksts & ";" & zuord & ";" & postext & ";;;;" & bwas & ";; _
_
Else
zeile1 = zeile1 & ";" & ksts & ";" & zuord & ";" & postext & ";X;;;" & bwas & "; _
_
End If
Else
zeile1 = zeile1 & ";" & ksts & ";" & zuord & ";" & postext & ";;;;" & bwas & ";;;;;" _
_
End If
zeile2 = buschh & ";" & koh & ";" & betrag & ";" & sth
zeile2 = zeile2 & ";" & ksth & ";" & zuord & ";" & postext & ";;;;" & bwah & ";;;;;"
' Schreiben der Daten in die vorher angegebene Datei
Print #1, kopfzeile & zeile1
Print #1, ";;;;;;;" & zeile2
End If
i = i + 1
Loop
Close #1
Workbooks("Meldung Lohnverst. Jan. 2016.xls").Close SaveChanges:=False
Kill "Z:\Neuer Ordner\Meldung Lohnverst. Jan. 2016.xls"
'_________________________________________________________________________________________
' Verweis auf Microsoft Outlook Bibliothek setzen
Dim objOL As Object
Dim objMail As Object
Dim Bezeichnung As String
Dim MAdr As String
Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItem(0)
Workbooks.Open Filename:="Z:\Neuer Ordner\Meldung Lohnverst. Jan. 2016.csv", Local:=True
Bezeichnung = ActiveWorkbook.Name
MAdr = "Test@t-online.de"
With objMail
.To = MAdr
.Subject = Bezeichnung
.body = "Hallo zusammen, " & vbCrLf & vbCrLf & "anbei erhalten Sie die Eingaben für die _
Lohnsteuerung für den Monat Januar 2016." & vbCrLf & vbCrLf & "Vielen Dank im Voraus." & vbCrLf _
& vbCrLf & "Mit freundlichen Grüßen" & vbCrLf & vbCrLf & "Blablabla"
.Attachments.Add ActiveWorkbook.FullName
.Display ' Display für Indirektversand oder .Send für Direktversand
End With
Set OMail = Nothing
Workbooks("Meldung Lohnverst. Jan. 2016.csv").Close SaveChanges:=False
Kill "Z:\Neuer Ordner\Meldung Lohnverst. Jan. 2016.csv"
Workbooks("Berechnungsblatt 44 - Freigrenze M017.xlsm").Sheets("Januar").Activate
End Sub