Hallo Tino,
vielen Dank für Deine Mühe. Leider funktioniert das mit der Leeren Spelta garnicht, die wird entweder nur vor die ersten Spalte gemacht, oder die daten landen in andren Spalten :-( .
Liegt sicher auch an mir.!
Vielleicht können wir es so schneller lösen, wenn ich mal alles zeige:
Sub Formular()
Dim Bereich As Range
Dim A As Long, B As Long
Dim Zelle As Range, CZelle As Range
Dim meAr(), LCount As Long
Set Bereich = Sheets("Ablage").Columns(4)
B = Application.WorksheetFunction.CountIf(Bereich, "Total C*")
ReDim meAr(B, 2)
For A = 1 To B
If A = 1 Then
Set Zelle = Bereich.Find("Total C*", , xlValues, 2, 1, 1, False, False)
Set CZelle = Zelle.EntireRow.Find("[*", , xlValues, 2, 1, 1, False, False)
If Not CZelle Is Nothing Then
meAr(LCount, 0) = Right$(CZelle, Len(CZelle) - InStrRev(CZelle, "["))
meAr(LCount, 0) = Left$(meAr(LCount, 0), InStr(meAr(LCount, 0), "]") - 1)
meAr(LCount, 1) = Sheets("Ablage").Cells(CZelle.Row, 5)
meAr(LCount, 2) = Sheets("Ablage").Cells(CZelle.Row + 1, 5)
LCount = LCount + 1
End If
Else
Set Zelle = Bereich.Find("Total C*", Zelle, xlValues, 2, 1, 1, False, False)
Set CZelle = Zelle.EntireRow.Find("[*", , xlValues, 2, 1, 1, False, False)
If Not CZelle Is Nothing Then
meAr(LCount, 0) = Right$(CZelle, Len(CZelle) - InStrRev(CZelle, "["))
meAr(LCount, 0) = Left$(meAr(LCount, 0), InStr(meAr(LCount, 0), "]") - 1)
meAr(LCount, 1) = Sheets("Ablage").Cells(CZelle.Row, 5)
meAr(LCount, 2) = Sheets("Ablage").Cells(CZelle.Row + 1, 5)
LCount = LCount + 1
End If
End If
Next A
With Sheets("Datenbestand")
.Range("C24:E33").Value = ""
.Range("C24").Resize(UBound(meAr, 1), UBound(meAr, 2) + 1) = meAr
End With
End Sub
Also, die erste INformationen soll in B bleiben, die zweite in C und di Dritte in D. Der Inhalt, der seither in E war, soll nun eins nach rechts rutschen, also in F. (Esoll nun leer bleiben)
Was muss ich denn da ändern ?
Danke Kai