csv-Import !! Lösung Nepumuk - Erweiterung ?

Hallo Nepumuk,
halle alle anderen,
"last easter-greeting" :)
Hallo Nepumuk,
leider konnte ich Deine Lösung aus dem Thread
https://www.herber.de/forum/archiv/1416to1420/t1417523.htm#1417523
er heute probieren !
Funktioniert einwandfrei :) - ein echtes Ostergeschenkt für mich ;)
Dein Code
Option Explicit

Public Sub IMPORTCSV()
Dim strFolder As String, strName As String
Dim lngRo
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
strFolder = .SelectedItems(1) & "\"
strName = Dir$(strFolder & "*.csv")
Do Until strName = vbNullString
Call Workbooks.OpenText(Filename:=strFolder & strName, Local:=True)
Rows(1).Delete
With ThisWorkbook.Worksheets(1)
lngRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
Call ActiveSheet.UsedRange.Copy(Destination:=.Cells(lngRow, 2))
.Cells(lngRow, 1).Value = strName
End With
Call ActiveWorkbook.Close(SaveChanges:=False)
strName = Dir$
Loop
End If
End With
End Sub

kopiert in die erste Spalte / in der ersten Zeile
den Dateinamen der jeweils importieren csv-Datei.
Ist es ein "Leichtes", diesen Dateinamen ebenfalls in JEDER importierte
Zeile ebenfalls einzufügen ? Ja, händisch kann ich dass - per Makro wäre es
noch cooler ;)
Hintergrund: später möchte ich alle importieren Daten per Pivot auswerten,
dafür wäre es hilfreich, wenn in Spalte A vor jedem Datensatz der
entsprechende Dateiname steht :)
Jetzt nach soviel Ostereier-Essen *grins*
noch ein Idee:
Der Code kopiert ja die Daten alles in einem bestimmten auszuwählenden
Verzeichnis in die xls.
Wäre es möglich, im Auswahl-Menue nur bestimmte Dateien
(gern auch Markierung per STRG-Taste)
die dann in eine bestehende xls (also "alte Daten bereits vorhanden")
dann jeweils "unten" anfügt ?
Meine Eier-Kreativität spinnt ?
Keine Ahnung - ich bin jedoch immer wieder guter Hoffnung,
in diesem Forum immer wieder tolle Lösungen zu finden ... UND
.. ich lerne immer wieder dazu :)
In froher Hoffnung
Besten Gruss
Stef@n

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
darum meinte ich ja testen.

Public Sub IMPORTCSV()
    Dim strName As String
    Dim lngRow As Long, lngIndex As Long
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        If .Filters.Count Then .Filters.Delete
        Call .Filters.Add("CSV-Dateien", "*.csv", 1)
        .Title = "Datenimport"
        If .Show Then
            For lngIndex = 1 To .SelectedItems.Count
                strName = .SelectedItems(lngIndex)
                Call Workbooks.OpenText(Filename:=strName, Local:=True)
                Rows(1).Delete
                With ThisWorkbook.Worksheets(1)
                    lngRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                    Call ActiveSheet.UsedRange.Copy(Destination:=.Cells(lngRow, 2))
                    .Range(.Cells(lngRow, 1), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 1)) _
                        .Value = Mid$(strName, InStrRev(strName, "\") + 1)
                End With
                Call ActiveWorkbook.Close(SaveChanges:=False)
            Next
        End If
    End With
End Sub

Gruß
Nepumuk

Public Sub IMPORTCSV() Dim strName As String Dim lngRow As Long Dim wkbZiel As Workbook, wksZiel As Worksheet Dim wkbTxt As Workbook, rngTxt As Range Dim varDatei As Variant If MsgBox("Andere Exceldatei als Zieldatei für importierte Daten wählen?", _ vbQuestion + vbYesNo, "Import CSV-Dateien") = vbYes Then varDatei = Application.Dialogs(xlDialogOpen).Show If varDatei = False Then Exit Sub End If Set wkbZiel = ActiveWorkbook Set wksZiel = wkbZiel.Worksheets(1) With wksZiel lngRow = .UsedRange.Row + .UsedRange.Rows.Count End With With Application.FileDialog(msoFileDialogOpen) .Title = "Bitte CSV-Datei(en) auswählen - Mehrfachauswahl ist möglich" .AllowMultiSelect = True .InitialFileName = "*.csv" If .Show Then Application.ScreenUpdating = False For Each varDatei In .SelectedItems Workbooks.OpenText Filename:=varDatei, Local:=True Set wkbTxt = ActiveWorkbook strName = wkbTxt.Name With wkbTxt.Worksheets(1) .Rows(1).Delete Set rngTxt = .UsedRange End With With wksZiel rngTxt.Copy Destination:=.Cells(lngRow, 2) .Range(.Cells(lngRow, 1), _ .Cells(lngRow + rngTxt.Rows.Count - 1, 1)).Value = strName lngRow = lngRow + rngTxt.Rows.Count End With wkbTxt.Close SaveChanges:=False Next Application.ScreenUpdating = True End If End With End Sub

Beliebteste Forumthreads (12 Monate)

csv-Import !! Lösung Nepumuk - Erweiterung ?

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread