Sub Maschine ()
Dim SuchErgebnis As Range
Dim lngZielZeile As Long
Dim SuchWert As String
Dim SuchWert1 As String
Dim lngZaehler As Long
Dim firstAddress
Dim intSpalte As Integer
lngZielZeile = 3
SuchWert = InputBox("Bitte die Maschinennummer eingeben z.b FI \ 6")
SuchWert1 = "In Produktion"
If StrPtr(SuchWert) = 0 Then Exit Sub
lngZaehler = 0
With Sheets("Produktionsplanung")
Set SuchErgebnis = .Range("A5:AY30").Find(SuchWert, LookIn:=xlValues, LookAt:=xlWhole)
Set SuchErgebnis = .Range("A5:AY30").Find(SuchWert1, LookIn:=xlValues, LookAt:=xlWhole)
If Not SuchErgebnis Is Nothing Then
firstAddress = SuchErgebnis.Address
Do
For intSpalte = 1 To 1
Sheets("MaschineNr1").Cells(lngZielZeile, 2) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 2 To 2
Sheets("MaschineNr1").Cells(lngZielZeile, 3) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 6 To 6
Sheets("MaschineNr1").Cells(lngZielZeile, 4) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 10 To 10
Sheets("MaschineNr1").Cells(lngZielZeile, 5) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 11 To 11
Sheets("MaschineNr1").Cells(lngZielZeile, 6) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 7 To 7
Sheets("MaschineNr1").Cells(lngZielZeile, 7) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 8 To 8
Sheets("MaschineNr1").Cells(lngZielZeile, 8) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 9 To 9
Sheets("MaschineNr1").Cells(lngZielZeile, 9) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 43 To 43
Sheets("MaschineNr1").Cells(lngZielZeile, 10) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
For intSpalte = 44 To 44
Sheets("MaschineNr1").Cells(lngZielZeile, 11) = .Cells(SuchErgebnis.Row, _
intSpalte)
Next
lngZielZeile = lngZielZeile + 1
lngZaehler = lngZaehler + 1
Set SuchErgebnis = .Range("A5:AY30").FindNext(SuchErgebnis)
Loop While Not SuchErgebnis Is Nothing And SuchErgebnis.Address <> firstAddress
MsgBox "Es wurden zum Suchwert " & SuchWert _
& vbCrLf & lngZaehler & " Datensätze kopiert"
Else
MsgBox "Kein Eintrag"
End If
End With
With Sheets("MaschineNr1")
For lngZielZeile = .Cells(.Rows.Count, 7).End(xlUp).Row To 3 Step -1
If .Cells(lngZielZeile, 7).Value = 20 Then
If .Cells(lngZielZeile, 8).Value >= 20 Then
.Rows(lngZielZeile).EntireRow.Delete
End If
End If
Next lngZielZeile
End With
End Sub