AW: VBA Zieldatei
20.06.2017 10:46:27
Sepp
Hallo Daniel,
ich schick dir mal meinen Code:
In der Datei Firma1.xlsm ist folgender Button:
Private Sub CommandButton1_Click()
Application.Run "Personal.xlsm!Test1"
End Sub
In Personal.xlsm soll dann der Code gestartet werden, somit bleibt nämlich die Date Firma1.xlsm mit nur wenige Makros usw...
Sub Test1() '
Private Sub CommandButton1_Click() in FirmaVorlage
Dim ablagepfad As String
Dim dateiname As String
Dim pfaderledigt As String
Dim zieldatei As Object
Dim quelle As Object
Dim letztezeile As Long
Dim zeilequelle
Dim DLG
Application.ScreenUpdating = False
'die Zieldatei, da wo das Makro ausgeführt wird
Set zieldatei = ActiveWorkbook.ActiveSheet 'ThisWorkbook.Sheets("Daten")
'Zeile in die eingetragen wird
letztezeile = zieldatei.Cells(Rows.Count, 1).End(xlUp).Row + 1
'pfad für die Ausgangs CSV Dateien
Set DLG = Application.FileDialog(msoFileDialogFolderPicker) 'Verzeichnis wählen
With DLG
.InitialFileName = "I:Vorlage_Firma\" 'Welches Verzeichnis soll voreingestellt sein
If .Show = True Then
ablagepfad = DLG.SelectedItems(1) & "\SM_csv\"
End If
'pfad wohin abgelegt werden soll, also die erledigten
pfaderledigt = .SelectedItems(1) & "\SM_erl\"
End With
'erste Datei suchen
dateiname = Dir(ablagepfad & "*.csv")
'wenn keine Datei gefunden, Meldung und Abbruch
If dateiname = "" Then
MsgBox "Keinen DATEN vorhanden.", , "Fehler bei Suche"
End
End If
'falls gefunden, alle durchgehen
Do Until dateiname = ""
'Dateien öffnen
Workbooks.Open ablagepfad & dateiname
Set quelle = ActiveWorkbook
'in Spaltenaufteilen
ActiveSheet.Columns(1).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
"""", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _
Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1)), TrailingMinusNumbers:=True
'Anzahl der einzutragendenzeilen ermitteln
zeilequelle = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
'Daten kopieren
quelle.Worksheets(1).Range(quelle.Worksheets(1).Cells(2, 1), _
quelle.Worksheets(1).Cells(zeilequelle, 9)).Copy zieldatei _
.Cells(letztezeile, 1)
'Datum und Zeit des Übertrages rein
zieldatei.Cells(letztezeile, 11) = Now
'Zeile für nächsten Eintrag neu setzen
letztezeile = letztezeile + zeilequelle - 1
'csv schließen
quelle.Close savechanges:=False
'CSV umbenennen und verschieben
Name ablagepfad & dateiname As pfaderledigt & Left(dateiname, Len(dateiname) - 4) _
& " " & Replace(Now, ":", ".") & ".csv"
'nächste CSV suchen
dateiname = Dir
Loop
MsgBox "Alle Dateien wurden gezogen"
'Formate noch anpassen, Spaltenbreite an Text anpassen + Format auf Zahl für Spalte B C
zieldatei.Columns("A:K").AutoFit
zieldatei.Columns("B:C").NumberFormat = "0"
With zieldatei.Columns("A:I").Borders
.Weight = xlThin
.LineStyle = xlContinuous
End With
Set zieldatei = Nothing
Set quelle = Nothing
Application.ScreenUpdating = True
End Sub
Ich hoffe du kannst mir erklären wie und wo ich des jetzt mache. :-)