Makro für Wort in Zeile suchen und enstrechende Spalte in neues Arbeitsblatt kopieren

Hi, ich stehe vor folgendem Problem:
Ich habe eine Ansammlung von Daten die sortiert werden muss. Dabei muss die erste Zeile nach einer Bezeichnung durchsucht werden und 2 dazugehörige Spalten in ein neues Arbeitsblatt kopiert werden. Wenn es den gesuchten Eintrag nicht gibt, sollen die 2 Spalten in der geordenten Reihenfolge leer bleiben. So wie in den beigefügten Bildern gezeigt.
Ich hoffe das es nicht zu schwer umzusetzten ist, da ich selbst nicht viel Verständnis darüber besitze. Ich bin über jede Hilfe dankbar : )

Wie es aussehen soll, wenn es sortiert wurde:

Wie die Rohdaten vorliegen:

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 239709

Url: https://administrator.de/forum/makro-fuer-wort-in-zeile-suchen-und-enstrechende-spalte-in-neues-arbeitsblatt-kopieren-239709.html

Ausgedruckt am: 23.12.2024 um 14:12 Uhr

4 Kommentare

Neuester Kommentar

Hallo Zebras,

könnte so aussehen.

Sub CopyData()
    Dim lCols As Long, lLastNum As Long, lFound As Long, i As Long, _
        strLast As String, strCurrHead, _
        wsCopy As Excel.Worksheet, wsPaste As Excel.Worksheet, _
        rgCopyHead As Excel.Range, rgFound As Excel.Range

    Const strConstHead = "Versuch_"  
    Set wsCopy = ThisWorkbook.Worksheets("Tabelle3")  
    Set wsPaste = ThisWorkbook.Worksheets("Tabelle2")  

    lCols = wsCopy.UsedRange.Columns.Count
    Set rgCopyHead = wsCopy.Range(wsCopy.Cells(1, 1), wsCopy.Cells(1, lCols))
    strLast = wsCopy.Cells(1, lCols - 1)
    lLastNum = CLng(Mid(strLast, InStrRev(strLast, "_") + 1))  

    For i = 1 To lLastNum
        strCurrHead = strConstHead & CStr(i)
        Set rgFound = rgCopyHead.Find(strCurrHead, , , xlWhole, , , True)
        If rgFound Is Nothing Then
            wsPaste.Cells(1, i * 2 - 1) = strCurrHead
            wsPaste.Cells(1, i * 2).ClearContents
        Else
            lFound = rgFound.Column
            wsCopy.Range(wsCopy.Columns(lFound), wsCopy.Columns(lFound + 1)).Copy
            wsPaste.Range(wsPaste.Columns(i * 2 - 1), wsPaste.Columns(i * 2)).PasteSpecial
            Application.CutCopyMode = False
        End If
    Next
End Sub

Ich habe als größte Versuchsnummer in der Kopfzeile die letzte in der zu kopierenden Tabelle angenommen. Keine Ahnung ob das so OK ist.

Grüße
rubberman

Vielen vielen Dank für deine schnelle Antwort. Und es ist fast exakt so wie ich es bräuchte :D Idealer wäre es, wenn nicht nach dem festen Wert "Versuch_" gesucht wird, sondern nach den Inhalten der 1. Reihe des Arbeitsblatt 2. - > Wie z.B. A1:"Lac-1-AAE-1.csv" ; C1: "Lac-1-AAE-2.csv" ; E1: "LAC-1-FoPi-1.csv" ; usw.
Beste Grüße Zebras

Hallo Zebras,

mir war nicht bewusst, dass die Überschriften in Tabelle2 bereits vollständig existieren.
Teste:

Sub CopyData()
    Dim lColsCopy As Long, lColsPaste As Long, lFound As Long, i As Long, _
        strCurrHead As String, _
        wsCopy As Excel.Worksheet, wsPaste As Excel.Worksheet, _
        rgCopyHead As Excel.Range, rgFound As Excel.Range

    Set wsCopy = ThisWorkbook.Worksheets("Tabelle3")  
    Set wsPaste = ThisWorkbook.Worksheets("Tabelle2")  

    lColsCopy = wsCopy.UsedRange.Columns.Count
    lColsPaste = wsPaste.UsedRange.Columns.Count
    Set rgCopyHead = wsCopy.Range(wsCopy.Cells(1, 1), wsCopy.Cells(1, lColsCopy))

    For i = 1 To lColsPaste Step 2
        strCurrHead = wsPaste.Cells(1, i)
        Set rgFound = rgCopyHead.Find(strCurrHead, , , xlWhole, , , True)
        If Not rgFound Is Nothing Then
            lFound = rgFound.Column
            wsCopy.Range(wsCopy.Columns(lFound), wsCopy.Columns(lFound + 1)).Copy
            wsPaste.Range(wsPaste.Columns(i), wsPaste.Columns(i + 1)).PasteSpecial
            Application.CutCopyMode = False
        End If
    Next
End Sub