4
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:
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:
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 239709
Url: https://administrator.de/contentid/239709
Printed on: April 19, 2024 at 15:04 o'clock
4 Comments
Latest comment
Hallo Zebras,
könnte so aussehen.
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
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 SubGrüße
rubberman
1
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
Beste Grüße Zebras
Hallo Zebras,
mir war nicht bewusst, dass die Überschriften in Tabelle2 bereits vollständig existieren.
Teste:
Grüße
rubberman
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 Subrubberman
1
Klappt perfekt. Tausend Dank : )
