Datei auslesen in eine andere Tabelle einfügen.

BasicC · 30. Mai 2018

Das ist schonmal super !!.
Wie könnte ich es ausbauen das ich auf ein command button drücke -> Die Datei auswähle -> und der mir dann sagt nach was möchtest du suchen und mir die Zahlen raushaut .

Yaslaw · 30. Mai 2018

Die entsprechenden Const durch Variablen ersetzen

Visual Basic:

    Dim srcPath As String
    Dim srcSearchValue As String

    '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")

BasicC · 30. Mai 2018

Code:

Private Sub CommandButton1_Click()

    'Testwerte. Müssen noch angepasst werden
    'Const C_SRC_PATH = "G:\IT\Karaguelle\Messwerte Kopieren\X590_DRL_DI_Mid_Outer_RH.txt"    'Quelldatei
    Dim srcPath As String
    Dim srcSearchValue As String

    '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")
    
    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
    
    'Ziel Workbook
    Set trgWb = ActiveWorkbook
    
    'Quell Workbook und Sheet
   ' Set srcWb = Workbooks.Add(C_SRC_PATH)
    '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 = C_SRC_SEARCH_VALUE 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
            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
        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
End Function

Da ist irgendetwas falsch Fehlermeldung: Objektvariable oder With-Blockvariable nicht festgelegt?

Yaslaw · 30. Mai 2018

Wo kommt die Fehlermeldung?
Zudem musst du natürlich nachher die Datei öffnen, die ausgewählt wurde
C_SRC_PATH und C_SRC_SEARCH_VALUE müssen aus dem Code verschwinden.
Die Anderen Konstanten braucht es aber weiterhin. Die sehe ich bei dir nicht mehr.

Visual Basic:

Public Sub test()
    'Testwerte. Müssen noch angepasst werden
    Const C_SRC_SEARCH_RANGE = "B:B"                        'Suchbereich
    Const C_TRG_WS_NAME = "TEST"                            'Name des Ziel-Sheets
    
    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 srcPath As String
    Dim srcSearchValue As String
    
    '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")
    
    '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
            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
        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

BasicC · 30. Mai 2018

OK. und jetzt eventuell noch wenn man den gesuchten Wert eingegeben hat das man danach sagt mach es nicht automatisch in TEST rein sondern man setzt selber den Namen fest. (falls es geht ob man es immer in test rein machen könnte aber immer eine spalte weiter.)

Yaslaw · 30. Mai 2018

Gleich wie der Suchwert. C_TRG_WS_NAME aus dem Code durch eine Variabel ersetzen und diese mittels InputBox() befüllen.

BasicC · 30. Mai 2018

Das habe ich hinbekommen

Wie mache ich das was ich in den Klammern geschrieben hatte ?
Das ich es immer in ein Arbeitsblatt kopiere aber jedesmal in eine andere Spalte.
Und es fehlt die Bezeichnung der Spalte wie bekomme ich die hin ?

Yaslaw · 30. Mai 2018

Du hast eigentlich alles was du dazu brauchst. Einfach mal den Code studieren und versuchen zu verstehen.

Visual Basic:

Dim trgColNr As Long
...
        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, trgColNr).Value
        End If

BasicC · 31. Mai 2018

Code:

Public Sub Suche()
    'Testwerte. Müssen noch angepasst werden
    Const C_SRC_SEARCH_RANGE = "B:B"                        'Suchbereich
                                'Name des Ziel-Sheets
    
    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 srcPath As String
    Dim srcSearchValue As String
    'Dim C_TRG_WS_Name
    
    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, trgColNr).Value
        End If
        
       '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
        '    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
      '  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

Ein Fehler liegt bei createOrGetWorksheet.Name = iWsName warum ? Verstehe dies nicht .

Yaslaw · 3. Juli 2018

Was für ein Fehler?
Bitte um Beschreibung Fehlverhalten, Fehlermeldungen etc.
Aber das weisst du ja inzwischen, dass wir diese Infos brauchen.

Datei auslesen in eine andere Tabelle einfügen.

BasicC

Erfahrenes Mitglied

Yaslaw

alter Rempler

BasicC

Erfahrenes Mitglied

Yaslaw

alter Rempler

BasicC

Erfahrenes Mitglied

Yaslaw

alter Rempler

BasicC

Erfahrenes Mitglied

Yaslaw

alter Rempler

BasicC

Erfahrenes Mitglied

Yaslaw

alter Rempler

Neue Beiträge