Hallo,
ich benötige ein Makro, mit dem ich einen Text anhand eines Merkmals (z.B. Prüfziffer) in einen neuen Reiter kopieren kann.
Der Aufbau ist wie folgt: In Spalte E stehen eine ganze Menge an Daten untereinander, von denen ich nur einen gewissen Teil benötige. Wenn z.B. die Prüfziffer "1" in Spalte E kommt, sollen alle darunter stehenden Werte in die Tabelle 2 kopiert werden, bis in Spalte E die Prüfziffer "2" kommt.
Kann jemand helfen?
Hallo,
Zitat:Kann jemand helfen?
... bei Deinen spärlichen Angaben eher nicht.
Ein Makro arbeitet mit festen Vorgaben. Da kann man nichts mit "undefinierten Teilmengen"
oder mit "mehr" oder "weniger" oder anderen WischiWaschi-Angaben programmieren.
Das sollte ein Roboter aber wissen.
Der Punkt geht an dich :19:
Genauer gesagt brauche ich ein Makro, welches einen definierten Textteil in einen neuen Reiter überträgt. Ich habe dir dazu eine Beispieldatei angehängt.
Innerhalb der Datei sollen die drei Felder mit der Bezeichnung "Text" in einen zweiten Reiter eingefügt werden. Wichtig ist hierbei, dass ab der Zahl zwei das Makro stoppt, auch wenn theoretisch noch weitere Textfelder folgen könnten.
Konnte ich deine Fragen beantworten?
Hi
Wenn man wüsste was du vor hast. Für deine Beispielangaben braucht es kein Makro. In Tab2 die Formel
Code:
=WENNFEHLER(INDEX(Tabelle1!$A$1:$A$100;VERGLEICH(1;Tabelle1!$A$1:$A$100;0)+(ZEILE(A1)/(ZEILE(A1)<VERGLEICH(2;Tabelle1!$A$1:$A$100;0)-1)););"")
Gleich hinter Vergleich steht die Prüfziffer.
Gruß Elex
Hallo,
danke für deine Formel. Sie funktioniert super. Wenn jemand dafür noch ein Makro hat, dann nehme ich das auch gerne, aber vielen Dank schon einmal an dich für deine Hilfe.
Hallo,
vielleicht so?
Code:
Sub prcKopieren()
Dim rngA As Range, rngB As Range
Dim lngRow As Long
With Worksheets("Tabelle2")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Worksheets("Tabelle1")
Set rngA = .Columns(5).Find(1, lookat:=xlWhole, LookIn:=xlValues)
Set rngB = .Columns(5).Find(2, lookat:=xlWhole, LookIn:=xlValues)
If Not rngA Is Nothing And Not rngB Is Nothing Then
.Rows(rngA.Row).Resize(rngB.Row - rngA.Row).Copy Worksheets("Tabelle2").Cells(lngRow, 1)
Else
MsgBox "Die 1 oder 2 wurde nicht gefunden"
End If
End With
End Sub
Hallo,
vielen Dank für das Makro. Funktioniert bestens. Ich teste noch ein bisschen, aber es funktioniert wirklich gut. Dankeschön.
Hallo,
könntest du mir noch bitte helfen? Wie müsste das Makro lauten, wenn in Tab2 die Überschrift in E2 soll und der komplette Text in F2 (alle drei Beispielzeilen mit dem Wort "Text")? Derzeitig werden die Überschrift und die Texte untereinander in Tab2 ab A1 geschrieben.
Weißt du, wie das geht?
Hallo,
meinst Du so?
Code:
Sub prcKopieren()
Dim rngA As Range, rngB As Range
Dim lngRow As Long
With Worksheets("Tabelle2")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With Worksheets("Tabelle1")
Set rngA = .Columns(5).Find(1, lookat:=xlWhole, LookIn:=xlValues)
Set rngB = .Columns(5).Find(2, lookat:=xlWhole, LookIn:=xlValues)
If Not rngA Is Nothing And Not rngB Is Nothing Then
' .Rows(rngA.Row).Resize(rngB.Row - rngA.Row).Copy Worksheets("Tabelle2").Cells(lngRow, 1)
.Rows(rngA.Row).Resize(rngB.Row - rngA.Row).Copy
Worksheets("Tabelle2").Cells(lngRow, 1).PasteSpecial Transpose:=True
Application.CutCopyMode = False
Else
MsgBox "Die 1 oder 2 wurde nicht gefunden"
End If
End With
End Sub
Hallo,
vielen Dank für deine Hilfe. Ich teste das ganze und gebe dir eine Rückinfo.
Funktioniert alles super. Danke für deine tolle Hilfe.