Option Explicit
Public Sub Biopsy()
Dim AllBiopsy As Worksheet: Set AllBiopsy = ActiveWorkbook.Sheets("Biopsy_forceps")
Dim BostonBiopsy As Worksheet: Set BostonBiopsy = ActiveWorkbook.Sheets("Biopsy Boston Scientific")
Dim lookFor As Range: Set lookFor = AllBiopsy.Range("A2:Z" & xlsGetLastRow(AllBiopsy))
Dim lookIn As Range: Set lookIn = BostonBiopsy.Range("A2:Z" & xlsGetLastRow(BostonBiopsy))
Dim row_1 As Range
Dim area1 As String, area2 As Range
Dim length1 As Variant, length2 As Variant
Dim channel1 As Variant, channel2 As Variant
Dim wire1 As Variant, wire2 As Variant
Dim coated1 As Variant, coated2 As Variant
Dim fenster1 As Variant, fenster2 As Variant
Dim needle1 As Variant, needle2 As Variant
Dim cup1 As String, cup2 As String
Dim box1 As Variant, box2 As Variant
Dim jaw1 As Variant, jaw2 As Variant
Dim color1 As Variant, color2 As Variant
'Dim i As Integer
For Each row_1 In lookFor.Rows
'area zum finden asuwählen
area1 = row_1.Cells(5).Value
Set area2 = lookIn.Columns(5).Find(area1, , xlValues, xlWhole)
If Not area2 Is Nothing Then
'Jaw
jaw1 = row_1.Cells(6).Value
jaw2 = area2.Offset(0, 1).Value
'Länge
length1 = row_1.Cells(7).Value
length2 = area2.Offset(0, 2).Value
'channel Länge zum vergleichen auswählen
channel1 = row_1.Cells(8).Value
channel2 = area2.Offset(0, 3).Value
'colorcode Länge zum vergleichen auswählen
color1 = row_1.Cells(9).Value
color2 = area2.Offset(0, 4).Value
'beschichtung zum vergleichen
coated1 = row_1.Cells(10).Value
coated2 = area2.Offset(0, 5).Value
'Fenster zum Vergleichen
fenster1 = row_1.Cells(11).Value
fenster2 = area2.Offset(0, 6).Value
'Nadel zum Vergleichen
needle1 = row_1.Cells(12).Value
needle2 = area2.Offset(0, 7).Value
'Cup zum Vergleichen
cup1 = row_1.Cells(13).Value
cup2 = area2.Offset(0, 8).Value
'box zum Vergleichen
box1 = row_1.Cells(14).Value
box2 = area2.Offset(0, 9).Value
'color code zum vergleichen
If length1 = length2 And channel1 = channel2 And _
fenster1 = fenster2 And needle1 = needle2 And _
cup1 = cup1 And color1 = color2 And _
coated1 = coated2 And jaw1 = jaw2 And _
box1 = box2 Then
row_1.Cells(18).Value = area2.Offset(0, -4).Value
ElseIf length1 >= length2 - 50 And length1 <= length2 + 50 And _
channel1 >= channel2 - 1 And channel1 <= channel2 + 1 And _
fenster1 = fenster2 And _
needle1 = needle2 And _
cup1 = cup1 And color1 = color2 And _
coated1 = coated2 And jaw1 = jaw2 And _
box1 = box2 Then
row_1.Cells(19).Value = area2.Offset(0, -4).Value
ElseIf length1 >= length2 - 50 And length1 <= length2 + 50 And _
channel1 >= channel2 - 1 And channel1 <= channel2 + 1 And _
fenster1 = fenster2 And _
needle1 = needle2 And _
cup1 = cup1 And _
coated1 = coated2 Then
row_1.Cells(20).Value = area2.Offset(0, -4).Value
ElseIf length1 >= length2 - 50 And length1 <= length2 + 50 And _
channel1 >= channel2 - 1 And channel1 <= channel2 + 1 And _
fenster1 = fenster2 And _
needle1 = needle2 And _
cup1 = cup1 And _
coated1 = coated2 Then
row_1.Cells(21).Value = area2.Offset(0, -4).Value
ElseIf length1 >= length2 - 80 And length1 <= length2 + 80 Then
row_1.Cells(22).Value = area2.Offset(0, -4).Value
End If
End If
Next row_1
End Sub
'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param Worksheet Das Worksheetobjekt, das durchsucht werden soll
' * @return Long Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
Const xlCellTypeLastCell = 11
'Zur letzten initialisierten Zeile gehen
xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
xlsGetLastRow = xlsGetLastRow - 1
Loop
End Function
