Tabellen vergleichen und äquivalente Zeile finden


Marma

Grünschnabel
#1
Hallo!

Ich muss vorab sagen, ich bin absoluter Neuling in VBA und beschäftige mich damit seit 2 Monaten.

Ich habe folgendes Problem:

Ich habe Eine Produkttabelle mit jeweils den Eigenschaften und Artikelnummern etc. in den Spalten.
Es sind 3 Tabellen vorhanden:

Eine Spalte der Tabelle A (Worksheet 1) muss in Tabelle B (Worksheet 2) gesucht und gefunden werden. (Das kriege ich wahrscheinlich noch hin!)
Dann sollen einige Spalten der Tabelle B mit entsprechenden Spalten der Tabelle C (auch Worksheet 2) verglichen/angenähert werden.
So möchte ich in Tabelle A äquivalente Produkte aus Tabelle C finden und hinter der jeweiligen Zeile einfügen.

Ich hoffe, ihr könnt mir da weiterhelfen, da ich nicht weiß, ob spezifische Befehle schon in VBA vorhanden sind.
Ich bin nicht sofort auf ein Quellcode hinaus, sondern suche nach Lösungsansätzen.

Viele Dank!
Marma
 
#3
Danke für deine Antwort und entschuldige, dass ich so spät antworte. Ich hab erstmal selbst nach Lösungen gesucht und leider komme ich nur langsam voran.
Die Sache mit ADODB und SQL versuche ich im späteren Stadium meines Lernprozesses.
Ich möchte die Variante mit den Schleifen ausprobieren. Nur.. wo und wie muss ich die in dem unteren Code einsetzen?

Soweit bin ich gekommen:

Ich habe ein Ausgangs-Workbook "Programmierung" (book1) mit Artikelnummern in Spalte A.
Wenn die Artikelnummer im Workbook "Plastic Stents for Tool"(book2) Sheet1 auftaucht, wird eine andere Zelle aus der Zeile herausgegeben.

Mein Problem:

Ich möchte die Artikelnummer von book 1 in book 2, sheet1 finden und einige Zellen (Eigenschaften mit cm-Angaben etc.), die sich rechts daneben befinden mit Zellen aus book2, sheet2 vergleichen.
Wenn die Zellen übereinstimmen oder nur einige davon minimal abweichen, soll die dazugehörige andere Zelle (Artikelnummer) von book2,sheet2 in book 1 kopiert werden.

Ich hoffe, dass das Problem verständlich ist...



Visual Basic:
Option Explicit

Sub VlookPlasticStent()
 

    Dim lookFor As Range
    Dim srchRange As Range

    'Ausgangsdatei
    Dim book1 As Workbook
    'PlasticStents
    Dim book2 As Workbook

     'Workbook Name für Plastic Stent
    Dim book2Name As String
    book2Name = "Plastic Stents for Tool.xlsx"

    'Workbook aus aktuellem Pfad entnehmen
    Dim book2NamePath As String
    book2NamePath = ThisWorkbook.Path & "\" & book2Name

    'Book 1 ist aktuelle Workbook
    Set book1 = ThisWorkbook

        'Wenn PlasticStent nicht offen, dann öffnen
        If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
        Set book2 = Workbooks(book2Name)

    With ActiveSheet

         Set lookFor = Range(book1.Sheets(1).Cells(2, 1), book1.Sheets(1).Cells(1000, 1))

         'value to find
        Set srchRange = book2.Sheets(1).Range("A:AK")    'source
        lookFor.Offset(0, 1).value = Application.VLookup(lookFor, srchRange, 37, False)

    End With

End Sub



Function IsOpen(strWkbNm As String) As Boolean

    On Error Resume Next

    Dim wBook As Workbook

    Set wBook = Workbooks(strWkbNm)

    If wBook Is Nothing Then    'Not open
        IsOpen = False
        Set wBook = Nothing
        On Error GoTo 0

    Else

        IsOpen = True
        Set wBook = Nothing
        On Error GoTo 0

    End If

End Function
Ich bedanke mich schon mal und hoffe ihr könnt mir da helfen. Habe gerade nen Brett vor dem Kopf!

Grüße
Marma
 
#4
Massgebend für den Vergleich ist ja der folgende Ausschnitt.
Visual Basic:
         Set lookFor = Range(book1.Sheets(1).Cells(2, 1), book1.Sheets(1).Cells(1000, 1))

         'value to find
        Set srchRange = book2.Sheets(1).Range("A:AK")    'source
        lookFor.Offset(0, 1).value = Application.VLookup(lookFor, srchRange, 37, False)
Du willst das für jede Zeil in Book1 machen? Dann kommt hier die Schleife hin

Ich habe mal ein Prototyp erstellt.
Die ID wird gesucht, der Wert in der Spalte B wird verglichen mit einer Toleranz von +-1.
Die Spalte C wird bei einer Übereinstimmung kopiert.
Visual Basic:
Public Sub test()
    Dim ws1 As Worksheet:   Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Dim ws2 As Worksheet:   Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    Dim lookFor As Range:   Set lookFor = ws1.Range("A2:C" & xlsGetLastRow(ws1))
    Dim lookIn As Range:    Set lookIn = ws2.Range("A2:C" & xlsGetLastRow(ws2))
    Dim row_1 As Range
    Dim id_1 As Long
    Dim value_1 As Long, value_2 As Long
    Dim found_2 As Range
  
    For Each row_1 In lookFor.rows
        id_1 = row_1.Cells(1).value  'Erste Spalte
        Set found_2 = lookIn.Columns(1).Find(id_1, , xlValues, xlWhole)
        'Prüfen ob die ID gefunden wurde
        If Not found_2 Is Nothing Then
            'Die Werte zum vergleichen auswählen
            value_1 = row_1.Cells(2).value
            value_2 = found_2.Offset(0, 1).value
            If value_1 >= value_2 - 1 And value_1 <= value_2 + 1 Then
                row_1.Cells(3).value = found_2.Offset(0, 2).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
 

Anhänge

#5
Danke Yaslaw, dein Prototyp hat mir sehr weitergeholfen! Ich bin leider auf weitere Probleme gestoßen...

Code:
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
Der Code soll alle passende Artikelnummern, also area2.Offset(0,-4).Value finden und ab row_1.Cells(18).Value alle gefunden Nummern eintragen und nicht nur einen. (Nimmt der Code nur die erste gefundene Nummer?) Es wäre schön, wenn er auch in Spalte 19,20 etc. weitere passende Zellen einträgt. Wenn das erledigt ist, dann zum Elseif gehen, ab der ersten leeren Spalte auffüllen, dann mit dem nächsten Elseif das gleiche. Kann man das so realisieren?

Viele Grüße
Marma