Anzeige

Datei auslesen in eine andere Tabelle einfügen.

#1
Hallo Leute

ich hab echt kein Plan von VBA.
Vorhandene Datei: - eine .txt Datei die hat mehrere Zahlen , Werte etc.

Meine Aufgabe ist es ein Code zu schreiben, welches die Datei mit einem Button öffnet( also da dachte ich dann mache ich ein Worksheet auf nenne es Start setze ein Button hin das Öffnen heißt der öffnet mir den Explorer und ich kann die jeweilige Datei auswählen).

So nachdem die ausgewähle Datei dann in der Excel Datei in einem neuen Arbeitsblatt geöffnet ist, soll ich ein Code schreiben welches mir die Zeilen ausliest von spalte B und wenn es auf Spalte B ein Buchstaben entdeckt soll es mir in ein neues Arbeitsplatt hinzufügen, wenn er das gemacht hat soll er noch den Wert bei Spalte i4 mitnehmen und ihn darunter im neuen Arbeitsblatt einfügen.

Visual Basic:
Sub CommandButton1_Click()


Dim wsTarget As Worksheet
Dim varDatei As Variant

wsTarget = Worksheet("Datei")

varDatei = Application.GetOpenFilename()
If varDatei = False Then
    MsgBox "Sie haben das Öffnen abgebrochen.", vbInformation, p_cstrAppName
Else
    MsgBox "Ausgewählte Datei:" & vbCrLf & varDatei, vbInformation, p_cstrAppName
End If

Set wsTarget = Worksheets("Datei")
End Sub
 

Anhänge

Zuletzt bearbeitet:

Yaslaw

n/a
Moderator
#4
Zeile 7 ist fehlerhaft und macht keinen Sinn.
Dito mit Zeile 16.

Gegenfrage.
Wenn der Code in Start!B:B etwas findet. Soll er dass dann einmal ausführen oder bei jedem treffer?
 
#7
Nein bei jedem Treffen bei dem neuen angelegten sheet den wert hinein kopieren
Und i4 ist als beispiel
Dann soll es beim nächsten von i5 u.s.w
 

Yaslaw

n/a
Moderator
#10
So auf die Schnelle:
Visual Basic:
Public Sub test()
    'Testwerte. Müssen noch angepasst werden
    Const C_SRC_PATH = "C:\Users\C754943\_TMP\Test3.csv"    'Quelldatei
    Const C_SRC_SEARCH_VALUE = "R308"                       'SuchWert
    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
    
    '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
 
#11
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

n/a
Moderator
#12
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")
 
#13
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

n/a
Moderator
#14
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
 
#15
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.)
 
#17
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

n/a
Moderator
#18
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
 
#19
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 .
 
Zuletzt bearbeitet:
Anzeige
Anzeige