Text von Prüfziffer zu Prüfziffer kopieren

[Roboter]

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?

[Käpt'n Blaubär]

Hallo,

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.

[Roboter]

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?

[Elex]

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

[Roboter]

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.

[Steffl]

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

[Roboter]

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?

[Steffl]

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

[Roboter]

Hallo,

vielen Dank für deine Hilfe. Ich teste das ganze und gebe dir eine Rückinfo.

[Roboter]

Funktioniert alles super. Danke für deine tolle Hilfe.