Hallo,
ich möchte gerne die Daten aus Sheets(„Data“), welche horizontal
angeordnet sind in das Sheets(„Auswahl“) in Gruppen einlesen lassen
Suchbegriff : Sheets(„Start“).cells(1,1)
Danke!
Gruß
Sigi
Sub Finden()
Dim lSp As Long, lSp1 As Long, lSp2 As Long, ii As Long
Dim C As Range
Dim sBegriff As String, FirstAddress As String
Dim Anz As Integer
Dim Z As Integer, X As Integer
Dim loEnde As Long, loEnde1 As Long
Dim AufAnz As Integer
Dim wksD As Object
Dim wksA As Object
Set wksD = Sheets(„Data“)
Set wksA = Sheets(„Auswahl“)
With wksA
For ii = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
Range(.Cells(ii, 1), .Cells(ii, 6)).Clear
Next ii
End With
sBegriff = Sheets(„Start“).Cells(1, 1)
If sBegriff = „“ Then Exit Sub
With wksD
lSp = 3 'Spalte in der gesucht werden soll
lSp1 = 5 'gibt an wieviele Datensätze es gibt
lSp2 = 6 'Beginn der Datensätze
loEnde = wksA.Cells(Rows.Count, 4).End(xlUp).Row
Set C = .Columns(lSp).Find(What:=sBegriff, LookAt:=xlWhole, LookIn:=xlValues)
If C Is Nothing Then Exit Sub
If Not C Is Nothing Then
FirstAddress = C.Address
loEnde = wksA.Cells(Rows.Count, 4).End(xlUp).Row
Set C = .Columns(lSp).FindNext©
AufAnz = .Cells(C.Row, lSp1).Value
For Z = loEnde To AufAnz
wksA.Cells(Z, 1).Value = .Cells(C.Row, lSp2).Value
wksA.Cells(Z, 2).Value = .Cells(C.Row, lSp2 + 1).Value
wksA.Cells(Z, 3).Value = .Cells(C.Row, lSp2 + 2).Value
wksA.Cells(Z, 4).Value = .Cells(C.Row, lSp2 + 3).Value
wksA.Cells(Z, 5).Value = .Cells(C.Row, lSp2 + 4).Value
wksA.Cells(Z, 6).Value = .Cells(C.Row, lSp2 + 5).Value
lSp2 = lSp2 + 7
Next Z
Do
Set C = .Columns(lSp).FindNext©
loEnde1 = wksA.Cells(Rows.Count, 4).End(xlUp).Row
AufAnz = .Cells(C.Row, lSp1).Value
For Z = loEnde1 To AufAnz
wksA.Cells(Z, 1).Value = .Cells(C.Row, lSp2).Value
wksA.Cells(Z, 2).Value = .Cells(C.Row, lSp2 + 1).Value
wksA.Cells(Z, 3).Value = .Cells(C.Row, lSp2 + 2).Value
wksA.Cells(Z, 4).Value = .Cells(C.Row, lSp2 + 3).Value
wksA.Cells(Z, 5).Value = .Cells(C.Row, lSp2 + 4).Value
wksA.Cells(Z, 6).Value = .Cells(C.Row, lSp2 + 5).Value
lSp2 = lSp2 + 7
Next Z
Loop While Not C Is Nothing And C.Address <> FirstAddress
End If
End With
End Sub
