Datei auslesen in eine andere Tabelle einfügen.

BasicC

Erfahrenes Mitglied
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

  • test Zahlen.txt
    966,5 KB · Aufrufe: 5
Zuletzt bearbeitet:
Die Text-Datei ist semicolon-getrennt.
Wieso importierst du sie nicht einach als csv?
 
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?
 
Bei jedem Treffer .
Zeile 7 und 16 sind aus irgendeinem script von dir dachte mach eventuell sinn :)
 
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
 
Ja da ist eine Kelvin Zahl die ungefähr so aussieht 43,82827K

Also bei fast jeder i ten zelle von i ist eine Zahl drin
 
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
 

Neue Beiträge

Zurück