Strings compare and insert result

[Benic]

Hello,

I use excel file Database with 2 sheets (Database_WO_blanks and Database_W_blanks). I use it to fill Bill of material with InStr function. First example with sheet Database_WO_blanks works fine, if there is a match in ActiveWorkBook (bill of material) and my database (Database_WO_blanks) this code inserts number from column B of Database_WO_blanks in column B of my Bill of material. In this case each device consists of 1 ref. number :


Description Ref.
White device 1
Green device 11
Double device 111
Device covered 1111

    On Error Resume Next


    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim i As Long
    Dim j As Long
    Dim Odabrano As Variant
    Dim Odabrano_1 As Variant
    Dim Kolona_pretrazivanje As Variant
    Dim Kolon_umetanje As Variant
        
    Kol_pret = UserForm7.TextBox1.Text
    Kol_umet = UserForm7.TextBox2.Text
    
    Kolona_pretrazivanje = Kol_pret
    Kolona_umetanje = Kol_umet
    
    
    Sheet_odabir = UserForm7.ListBox1.Text


    Odabrano = Sheet_odabir
    
    Sheet_odabir_1 = UserForm7.ListBox2.Text


    Odabrano_1 = Sheet_odabir_1


      
    Set s1 = ActiveWorkbook.Sheets(Odabrano_1)
          
    Set s2 = Workbooks("Database.xlsm").Sheets(Odabrano)
        
      
    Application.ScreenUpdating = False


    'Loop sheet 1
    For i = 2 To s1.Cells(Rows.Count, Kolona_pretrazivanje).End(xlUp).Row
        'Loop sheet 2
        For j = 2 To s2.Cells(Rows.Count, 1).End(xlUp).Row
            'If match found
            If InStr(1, s1.Cells(i, Kolona_pretrazivanje), s2.Cells(j, 1), vbTextCompare) >= 1 Then
                s1.Cells(i, Kolona_umetanje) = s2.Cells(j, 2) 
                Exit For
            End If
        Next j
    Next i


    Application.ScreenUpdating = True


On Error GoTo 0

I would like to adapt this code to function with sheet Database_W_blanks. In this case each device consists of 4 different ref. numbers. And I would like to add all 4 ref. numbers if we found match. I made a code but it doesn work, please see result in my Bill of material, it works only for row - Device covered and after that it repeats.

Sheet Database_W_blanks
Description Ref.
White device 1
2
3
4
Green device 11
22
33
44
Double device 111
222
333
444
Device covered 1111
2222
3333
4444

On Error Resume Next


    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim i As Long
    Dim j As Long
    Dim Odabrano As Variant
    Dim Odabrano_1 As Variant
    Dim Kolona_pretrazivanje As Variant
    Dim Kolon_umetanje As Variant
    Dim R As Long
        
    
    Kol_pret = UserForm7.TextBox1.Text
    Kol_umet = UserForm7.TextBox2.Text
    
    Kolona_pretrazivanje = Kol_pret
    Kolona_umetanje = Kol_umet
    
    
    Sheet_odabir = UserForm7.ListBox1.Text


    Odabrano = Sheet_odabir
    
    Sheet_odabir_1 = UserForm7.ListBox2.Text


    Odabrano_1 = Sheet_odabir_1


    
            
    Set s1 = ActiveWorkbook.Sheets(Odabrano_1) ' To je troškovnik
    
         
    Set s2 = Workbooks("Baza_usporedba.xlsm").Sheets(Odabrano) ' To je baza podataka
        
      
    Application.ScreenUpdating = False


    'Loop sheet 1
    For i = s1.Cells(Rows.Count, Kolona_pretrazivanje).End(xlUp).Row To 2 Step -1    
        'Loop sheet 2
        For j = s2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'For j = 1 To s2.Cells(Rows.Count, 1).End(xlUp).Row
        
            'If match found
            
                      
            If InStr(1, s1.Cells(i, Kolona_pretrazivanje), s2.Cells(j, 1), vbTextCompare) >= 1 Then
            
               
            s1.Cells(i + 1, Kolona_pretrazivanje).EntireRow.Insert Shift:=xlDown
            s1.Cells(i + 2, Kolona_pretrazivanje).EntireRow.Insert Shift:=xlDown
            s1.Cells(i + 3, Kolona_pretrazivanje).EntireRow.Insert Shift:=xlDown
            's1.Cells(i + 4, Kolona_pretrazivanje).EntireRow.Insert Shift:=xlDown
            


             s1.Cells(i, Kolona_umetanje) = s2.Cells(j, 2)  '
             s1.Cells(i + 1, Kolona_umetanje) = s2.Cells(j + 1, 2) ' 
             s1.Cells(i + 2, Kolona_umetanje) = s2.Cells(j + 2, 2) ' 
             s1.Cells(i + 3, Kolona_umetanje) = s2.Cells(j + 3, 2) '
        
        
           
                            
        Exit For
            
            
            End If
        Next j
    Next i


    Application.ScreenUpdating = True


On Error GoTo 0

Result Bill of material:

White device 444
1111
2222
3333
Green device 444
1111
2222
3333
Double device 444
1111
2222
3333
Device covered 1111
2222
3333
4444

Ref. are all in column B, sorry for copy paste errors.
Is there better way to do this, maybe select range with offset?

Thanks

 

[Rijnsent]

Hi Benic,
what about a small loop before you run your procedure filling column A? Basically: run from first row to last and if the cell is empty, take the value of the cell above? Or can't you touch column A?
If that is the case: in your loop, set a value for "LastDevice" and state "If Range("A" & i).value <> "" Then LastDevice = Range("A" & i).value , in that case you'll always have the last value for the device in your loop.
Hope that isn't too cryptic?
Cheers,
Koen