"Do ohne Loop" wer findet den Fehler

Sub mit_anderer_JA_NEIN_Abfrage()
' Worksheet3 wird ausgewählt und in der ersten Zeile Zellen mit "/" durch "_" ersetzt, damit spä _
_
ter die Reiter benannt werden können
Worksheets(3).Select
Rows(1).Select
Selection.Replace What:="/", Replacement:="_", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Do
On Error Resume Next
strS = InputBox("Suchbegriff:", Value  "", strS)
If StrPtr(strS) = 0 Or Len(strS) = 0 Then Exit Do
Set rngT = Rows(1).Find(What:=strS, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).EntireColumn.Copy
Sheets.Add After:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Paste Destination:=Sheets(Worksheets.Count).Columns("X:X")
ActiveSheet.Name = Range("X1")
' Spalte wird nach leeren Zeilen durchsucht. Falls gefunden wird "keine Angabe" in die  _
Leerzeile eingetragen
Dim zelle As Range
Dim bereich As Range
Set bereich = Range("X1:X5000")
For Each zelle In bereich
If zelle.Value = "" Then zelle.Value = "keine Angabe gemacht"
Next zelle
' Es erscheint eine Ja/Nein Abfrage ob der Zellinhalt getrennt werden soll. Dabei wird nach  _
Komma gesucht
Dim a
Dim rngFound As Range
Dim ar As Variant
Dim i As Integer
Dim rngSource As Range
If MsgBox("Wollen Sie denn Zellinhalt trennen", vbYesNo) = vbYes Then
Set rngSource = ActiveSheet.Range("X:X")
With rngSource.EntireColumn
Set rngFound = .Find(What:=",", LookIn:=xlFormulas, LookAt:=xlPart)
While Not rngFound Is Nothing
ar = Split(rngFound.Value, ",")
.Rows(rngFound.Row + 1).Resize(UBound(ar)).Insert xlShiftDown
For i = 0 To UBound(ar)
rngFound.Offset(i, 0).Value = ar(i)
Next
Set rngFound = .FindNext(rngFound)
Wend
End With
' PivotTabelle wird erstellt
Dim pt As PivotTable
Dim cacheofpt As PivotCache
Dim pf As PivotField
Dim pi As PivotItem
With rngSource
Set cacheofpt = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:="'" & rngSource.Parent.Name & "'!" _
& rngSource.Range("A1").Address(True, True, xlR1C1) & ":" _
& .Parent.Cells(.Row + .Rows.Count - 1, .Column).Address(True, True, xlR1C1))
End With
Set pt = cacheofpt.CreatePivotTable(TableDestination:=ActiveSheet.Range("A1"))
With pt
With .PivotFields(rngSource.Range("A1").Text)
.Orientation = xlRowField
.Position = 1
End With
End With
' BalkenChart wird erstellt
With Charts.Add
.ChartType = xlColumnClustered
.ApplyLayout (5)
.ClearToMatchStyle
.ChartStyle = 3
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = Worksheets(Worksheets.Count).Range("X1" _
_
)
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Anzahl der Tickets"
.SetSourceData Source:=ActiveSheet.Range("b1"), PlotBy:=xlColumns
.Location where:=xlLocationAsObject, Name:="Diagramm"
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlRight
ActiveChart.HasTitle = False
End With
Worksheets(3).Select
' Diagramme werden angeordnet. 3 Diagramme pro Zeile
Dim objShape As ChartObject, MerkShape As ChartObject
Dim iCount As Integer
iCount = 1
For Each objShape In Sheets("Diagramm").ChartObjects
With objShape
If MerkShape Is Nothing Then
.Left = 10
.Top = 150
Else
iCount = IIf(iCount = 3, 1, iCount + 1)
If iCount > 1 Then
.Top = MerkShape.Top
.Left = MerkShape.Left + MerkShape.Width + 100
Else
.Left = 10
.Top = MerkShape.Top + MerkShape.Height + 100
End If
End If
Set MerkShape = objShape
End With
Next objShape
Else
With rngSource
Set cacheofpt = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:="'" & rngSource.Parent.Name & "'!" _
& rngSource.Range("A1").Address(True, True, xlR1C1) & ":" _
& .Parent.Cells(.Row + .Rows.Count - 1, .Column).Address(True, True, xlR1C1))
End With
Set pt = cacheofpt.CreatePivotTable(TableDestination:=ActiveSheet.Range("A1"))
With pt
With .PivotFields(rngSource.Range("A1").Text)
.Orientation = xlRowField
.Position = 1
End With
End With
' BalkenChart wird erstellt
With Charts.Add
.ChartType = xlColumnClustered
.ApplyLayout (5)
.ClearToMatchStyle
.ChartStyle = 3
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = Worksheets(Worksheets.Count).Range("X1" _
_
)
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Anzahl der Tickets"
.SetSourceData Source:=ActiveSheet.Range("b1"), PlotBy:=xlColumns
.Location where:=xlLocationAsObject, Name:="Diagramm"
ActiveChart.HasLegend = True
ActiveChart.Legend.Select
Selection.Position = xlRight
ActiveChart.HasTitle = False
End With
Worksheets(3).Select
Loop
' Diagramme werden angeordnet. 3 Diagramme pro Zeile
Dim objShape As ChartObject, MerkShape As ChartObject
Dim iCount As Integer
iCount = 1
For Each objShape In Sheets("Diagramm").ChartObjects
With objShape
If MerkShape Is Nothing Then
.Left = 10
.Top = 150
Else
iCount = IIf(iCount = 3, 1, iCount + 1)
If iCount > 1 Then
.Top = MerkShape.Top
.Left = MerkShape.Left + MerkShape.Width + 100
Else
.Left = 10
.Top = MerkShape.Top + MerkShape.Height + 100
End If
End If
Set MerkShape = objShape
End With
Next objShape
End If
End Sub
Vielen Dank für die Mühe