CSV importieren und in Mappe bringen
14.02.2021 17:15:45
Jürgen
brauche mal wieder Unterstützung bei der Umsetzung eines "Teilprojekts".
Hab mein Glück bereits hier: https://www.tutorials.de/threads/neues-vba-projekt-mit-mehreren-optionen.409812/ Versucht aber bisher gabs dort noch keine Antwort, deswegen wollte ich mal hier nach Hilfe suchen.
Unter dem Link findet ihr übrigens die Idee zum fertigen Projekt.
Moment hänge ich daran fest eine CSV Datei per Button zu "öffnen/einzulesen" und diese dann an eine neue Arbeitsmappe weiterzugeben. Kurz zum Grund dafür, ich muss täglich mehrere CSV Dateien die ich per Mail bekomme abspeichern, bearbeiten und die Zellen 4-61 löschen, die dritte Spalte ich den sich Zahlen befinden das Format anpassen und Abschließend wieder als CSV speichern.
Das Einlesen der CSV in der von mir gewünchten Formatierung klappt bereits bestens, ich finde halt nur nicht raus wie ich den Code anpassen muss damit das ganze ich eine neue Mappe geht.
Option Explicit
Private worksheet_ As Worksheet
Private DefaultPath As String
Private csv_ As String
Public Sub Import()
DefaultPath = Environ("Userprofile") & "\Documents\"
Set worksheet_ = ThisWorkbook.Sheets(1)
worksheet_.UsedRange.Clear
'//Select File
csv_ = CsvFilePath
If csv_ = "" Then Exit Sub
'//Import the Data
AddCSV
End Sub
Private Function CsvFilePath() As String
Dim FileDialog_ As FileDialog
Dim selection_ As Variant
Set FileDialog_ = Application.FileDialog(msoFileDialogFilePicker)
With FileDialog_
.Filters.Add "CSV", "*.csv", 1
.AllowMultiSelect = False
.InitialFileName = DefaultPath
If .Show = -1 Then
For Each selection_ In .SelectedItems
CsvFilePath = selection_
Next selection_
End If
End With
Set FileDialog_ = Nothing
End Function
Sub qry() 'QueryTable löschen
Dim qry As QueryTable
Dim wks As Worksheet
For Each wks In Workbooks("Mappe1.xls").Worksheets
For Each qry In wks.QueryTables
qry.Delete
Next 'qry
Next 'wks
End Sub
Private Sub AddCSV()
With worksheet_.QueryTables.Add(Connection:="TEXT;" & csv_, _
Destination:=Range("A1"))
.Name = "" .FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = ","
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
End Sub
Nun habe mehrere Idee und Versuche unternomme um das ganze in eine neue Mappe zu kriegen.
Diese soll, sobald es dann funktioniert, noch Automatisch nach dem Importieren unter Vorgabe eines Dateinames mit "Rückfrage" gespeichert und dann geschlossen werden. Aber daran werde ich mich später Versuchen.
Hier mal mein letzten Versuche:
'1.
Private Sub AddCSV()
Dim origWb As Workbook
origWb = Workbook.Name
Dim newWb As Workbook
newWb = Workbooks.Name
With Workbook(newWb).worksheet_.QueryTables.Add(Connection:="TEXT;" & csv_,
Destination:=Workbook(newWb).Sheets(newWks).Range("A1"))
.Name = ""
'2.
Private Sub AddCSV()
Dim origWb As Workbook
Set origWb = Workbook.Name
Dim newWb As Workbook
Set newWb = Workbook.Name
newWb = Workbook.Activate
Dim newWks As Worksheet
With Aktiveworksheet(newWb)_.QueryTables.Add(Connection:="TEXT;" & csv_,
Destination:=ActiveWorkbook.Sheets(newWks).Range("A1"))
.Name = ""
Schönen Sonntag noch
VG