Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1628to1632
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Textdatei einlesen und nach genauem Begriff suchen

Textdatei einlesen und nach genauem Begriff suchen
04.07.2018 09:04:21
Kemal

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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Textdatei einlesen und nach genauem Begriff suchen
04.07.2018 09:05:27
Kemal
Wie bekomme ich es hin, den gesuchten Wert immer eine Spalte weiter zu importieren im gleichen Arbeitsblatt vom vorigen ?
Anzeige

313 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige