Private Sub CommandButton1_Click()
'Testwerte. Müssen noch angepasst werden
Const C_SRC_SEARCH_RANGE = "B:B" 'Suchbereich
'Const C_TRG_WS_NAME = "Daten"
Const C_COLNR_I = 9 'i ist Spalte 9
Dim srcWb As Workbook
Dim srcWs As Worksheet
Dim trgWb As Workbook
Dim trgWs As Worksheet
Dim r As Range
Dim trgLastRowNr As Long
Dim actAlerts As Boolean
Dim C_TRG_WS_NAME As String
Dim srcPath As String
Dim srcSearchValue As String
' Dim trgColNr As Long
'Dateipfad ermitteln
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "CSV Files", "*.csv"
.Filters.Add "All Files", "*.*"
.FilterIndex = 1
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Keine Datei ausgewählt, Vorgang wird abgebrochen", vbExclamation + vbOKOnly
Exit Sub
End If
srcPath = .SelectedItems(1)
End With
'Suchwert abfragen
srcSearchValue = InputBox("Suchwert in Spalte B")
C_TRG_WS_NAME = InputBox("Name des Arbeitsblattes")
'Ziel Workbook
Set trgWb = ActiveWorkbook
'Quell Workbook und Sheet
Set srcWb = Workbooks.Add(srcPath)
Set srcWs = srcWb.Worksheets(1)
'Das CSV ist als Text in der ersten Spalte - Das ganze mit TextToColumns auf die Spalten _
aufteilen
actAlerts = Application.DisplayAlerts 'aktuelle DisplayAlerts merken
Application.DisplayAlerts = False 'DisplayAlerts ausschalten
srcWs.Range("A:A").TextToColumns Destination:=srcWs.Range("A1"), DataType:=xlDelimited, _
Semicolon:=True
Application.DisplayAlerts = actAlerts 'DisplayAlerts zurücksetzen
'Die Spalte B durchsuchen
For Each r In srcWs.Range(C_SRC_SEARCH_RANGE)
If r.Value = srcSearchValue Then
'Falls das Ziel-Sheet noch nicht definiert wurde, das machen (wird nur beim ersten _
Treffer ausgeführt)
If trgWs Is Nothing Then
Set trgWs = createOrGetWorksheet(trgWb, C_TRG_WS_NAME)
trgLastRowNr = trgWs.Cells.SpecialCells(xlCellTypeLastCell).Row
' trgColNr = trgWs.Cells.SpecialCells(xlCellTypeLastCell).Column + 1
End If
'Nächste Freie Zeilen ermitteln
trgLastRowNr = trgLastRowNr + 1
'Wert aus Spalte I übernehmen
trgWs.Cells(trgLastRowNr, 1) = srcWs.Cells(r.Row, C_COLNR_I).Value
' trgWs.Cells(trgLastRowNr, 1) = srcWs.Cells(r.Row, trgColNr).Value
End If
Next r
srcWb.Close False
End Sub
'/**' * Gibt ein Worksheet anhand des Namens zurück. Exisitert es noch nicht, wird es erstellt
' * @param Workbook
' * @param String
' * @return Worksheet
' */
Private Function createOrGetWorksheet(ByRef ioWb As Workbook, ByVal iWsName As String) As _
Worksheet
Dim ws As Worksheet
For Each ws In ioWb.Worksheets
If (UCase(ws.Name) = UCase(iWsName)) Then
Set createOrGetWorksheet = ws
Exit Function
End If
Next ws
Set createOrGetWorksheet = ioWb.Worksheets.Add
createOrGetWorksheet.Name = iWsName
End Function