Hallo zusammen,

kann mir bitte jemand meinen Code so abändern, dass nicht die ganze Zeile in Eingabe kopiert wird, sondern nur die Zellen A-J der jeweils gesuchten Zeile?

Ich vermute das Problem ist diese Zeile oder?

    rBereich.EntireRow.Copy WSh.Cells(iZeile, "A").EntireRow

anbei mein verwendeter Code:

Dim rBereich As Range
  Dim sIchsuche As String, sErsteAdresse As String
  Dim sBer As String, sArr() As String
  Dim WSh As Worksheet, iZeile As Long, i As Long, iGefunden As Long
  Dim bCheck As Boolean

  sIchsuche = TextBox1
  If StrPtr(sIchsuche) = 0 Then Exit Sub
  If sIchsuche = "" Then
     MsgBox "Nix kon ma ned findn!", vbCritical, "Suche"
     Exit Sub
  End If

  Set WSh = Worksheets("Eingabe")
  WSh.Range("A8:J1000").Clear
 

With Worksheets("Bestand").Range("A:J")
      sArr = Split(sIchsuche)
      Set rBereich = .Find(sArr(0), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
      If Not rBereich Is Nothing Then
         sErsteAdresse = rBereich.Address
         Do
            iZeile = WSh.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If iZeile < 8 Then iZeile = 8
            bCheck = True
            If UBound(sArr) > 0 Then
               For i = 1 To UBound(sArr)
                   On Error Resume Next
                   sBer = rBereich.Row & ":" & rBereich.Row
                   If Application.WorksheetFunction.Match(sArr(i) & "*", .Range(sBer), 0) = 0 Then
                      bCheck = False: Exit For
                   End If
                  Next i
               On Error GoTo 0
            End If
            If bCheck Then
               rBereich.EntireRow.Copy WSh.Cells(iZeile, "A").EntireRow
            End If
            Set rBereich = .FindNext(rBereich)
         Loop While Not rBereich Is Nothing And rBereich.Address <> sErsteAdresse

      End If
  End With