Hallo Horst,
ich hab die Prozeduren jetzt so umgestrickt, dass du Varianten für den Kopiervorgang einrichten kannst.
Für den Kopiervorgang und sas Prüfen gibt es Subroutinen, deren Parameter von der Hauptroutine aus übergeben werden.
Gruß
Franz
Sub CSV_Import_Variante1()
'Daten aus Bereich C8:Fxxx importieren
Call CSV_Dateien_importieren(strZelleDatum:="B7", ZeileStart:=8, _
Spalte_1:=3, Spalte_L:=6, Spalte_Last:=3, bolPruefen:=True, _
SpaltePruefen:=1, PruefWert:="PP")
End Sub
Sub CSV_Dateien_importieren(strZelleDatum As String, ZeileStart As Long, _
Spalte_1 As Long, Spalte_L As Long, Optional Spalte_Last As Long = 1, _
Optional bolPruefen As Boolean = False, _
Optional SpaltePruefen As Long = 1, _
Optional PruefWert As Variant)
' Daten aus CSV-Dateien einfügen, Daten sind durch Semicolon getrennt, _
Dezimalstelle ist Punkt
' im aktiven Blatt werden Daten aus CSV Dateien im gewählten Verzeichnis eingefügt
Dim wb As Workbook, wks As Worksheet, wbAktiv As Workbook, wksAktiv As Worksheet
Dim rngZelle As Range
Dim strVerzeichnis As String
Dim Dateiname As Variant, DateinameTXT As String
Dim lngZeilenbereich As Long, ZeileLast As Long
'strZelleDatum = Adresse der Zelle mit Datum in CSV-Datei
'ZeileStart = Zeile ab der Daten aus CSV-Datei kopiert werden sollen
'Spalte_1 = 1. Spalte, die aus CSV-Datei kopiert werden soll
'Spalte_L = letzte Spalte, die aus CSV-Datei kopiert werden soll
'Spalte_Last = Spalte, in der die letzte Zeile mit Daten ermittelt werden soll
'bolPruefen = wenn True dann werden die Werte in der Prüfspalte geprüft
'SpaltePruefen = Nummer der Spalte, deren Werte geprüft werden solen
'PruefWert = Wert der in der Prüfspalte übereinstimmen soll
Dateiname = Application.GetOpenFilename(FileFilter:="CSV (*.csv), *.csv", _
Title:="CSV-Datei im Verzeichnis auswählen")
If Dateiname = False Then Exit Sub
strVerzeichnis = VBA.CurDir
Set wbAktiv = ActiveWorkbook
Set wksAktiv = ActiveSheet
'Nächste freie Zelle in Spalte B (2) am Ende suchen
Set rngZelle = wksAktiv.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
Dateiname = Dir(strVerzeichnis & Application.PathSeparator & "*.csv")
Application.ScreenUpdating = False
Do Until Dateiname = ""
'CSV-Datei temporär als txt-Datei kopieren
VBA.FileCopy Source:=Dateiname, Destination:=Left(Dateiname, Len(Dateiname) - 3) & "txt"
DateinameTXT = Left(Dateiname, Len(Dateiname) - 3) & "txt"
'Umbenannte Kopie öffnen
Application.Workbooks.OpenText Filename:=DateinameTXT, Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=True, _
Comma:=False, _
Space:=False, _
Other:=False, _
DecimalSeparator:=".", ThousandsSeparator:=","
Set wb = ActiveWorkbook
Set wks = wb.Worksheets(1)
With wks
'ggf. Werte prüfen und Zeilen Löschen
If bolPruefen = True Then
Call Ceck_Spalte_Wert(wksPruef:=wks, PruefSpalte:=SpaltePruefen, Wert:=PruefWert, _
Zeile1:=ZeileStart)
End If
'Letzte Zeile mit Daten ermitteln
ZeileLast = .Cells(.Rows.Count, Spalte_Last).End(xlUp).Row
'Daten Kopieren
lngZeilenbereich = ZeileLast - ZeileStart + 1
If lngZeilenbereich > 0 Then
.Range(.Cells(ZeileStart, Spalte_1), .Cells(ZeileLast, Spalte_L)).Copy
rngZelle.PasteSpecial Paste:=xlPasteValues
'Datum aus CSV-Datei in Spalte links von den Daten einfügen
wksAktiv.Range(rngZelle.Offset(0, -1), rngZelle.Offset(lngZeilenbereich - 1, -1)). _
Value _
= .Range(strZelleDatum)
'Nächste Einfügezelle setzen
Set rngZelle = rngZelle.Offset(lngZeilenbereich, 0)
End If
End With
Application.DisplayAlerts = False
wb.Close savechanges:=False
'TXT-Kopie wieder löschen
VBA.Kill (DateinameTXT)
Application.DisplayAlerts = True
Dateiname = Dir
Loop
Application.ScreenUpdating = True
End Sub
Sub Ceck_Spalte_Wert(wksPruef As Worksheet, PruefSpalte As Long, Wert As Variant, _
Optional Zeile1 As Long = 1)
'Im Tabellenblatt alle Zeilen Löschen, deren Zellinhalt in Prüfspalte _
verschieden von Wert ist.
'wksPruef = zu pruefendes Tabellenblatt
'PruefSpalte =Spalte deren Inhalt geprüft werden soll
'Wert = Prüfwert
'Zeile1 =Zeile ab der geprüft werden soll
Dim Zeile As Long, ZeileL As Long
With wksPruef
ZeileL = .Cells.SpecialCells(xlCellTypeLastCell).Row
For Zeile = Zeile1 To ZeileL
If Cells(Zeile, PruefSpalte).Value Wert Then
.Rows(Zeile).ClearContents
End If
Next
.Range(.Cells(Zeile1, 1), .Cells(ZeileL, 1)).SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete Shift:=xlShiftUp
End With
End Sub