index/match two sheets each value in list but returns only last value match

K

KDS14589

Board Regular
Joined
Jan 10, 2019
Messages
216
Office Version
  1. 2016
Platform
  1. Windows
I have 2 worksheets that I’m trying an index/match.

Sheet1 has a column of data (color hex #’s) starting in K2 and goes down (presently at 8 rows) (last row is defined as ‘ LRselected’)

Sheet3 has a 2 columns of data listing color names starting in A2 and corresponding Hex numbers in B2 and goes down (presently at 30282 rows) (last row is defined as ‘ Lastr3’)

My code for the last rows is

​

VBA Code: 
With Sheet1

Dim Lastr1 As Long

Lastr1 = .Range("C" & .Rows.Count).End(xlUp).Row 'presently at 2863



Dim LRselected As Long

LRselected = .Range("K" & .Rows.Count).End(xlUp).Row 'presently at 8

End With



With Sheet3

Dim Lastr3 As Long

Lastr3 = .Range("A" & .Rows.Count).End(xlUp).Row 'presently at 30282

End With



My experimental code for the index/match is



VBA Code: 
Dim CLL1 As Range

Dim r As Long

For r = 2 To LRselected



For Each CLL1 In Sheet1.Range("K2:K" & LRselected).Rows

If CLL1.Value <> "" Then

CLL1.Offset(0, 5).Value = WorksheetFunction.Index(Sheet3.Range("A2:A" & Lastr3), WorksheetFunction.Match(Sheet1.Cells(r, "K"), Sheet3.Range("B2:B" & Lastr3), 0))

End If

If CLL1.Value = "" Then

CLL1.Offset(0, 5).Value = ""

End If

Next



This code matches the hex number listed on Sheet1 in column “K” with Sheet3 column “B” and gives the Color Name from Sheet3 column “A” into column “P” on Sheet1 , but it gives the match from the last value in column “K” into all cells in column “P”.
I'm trying to get a match for EACH value listed in "K" but it returns only match for the last value in "K'.
Do I need to add/modify this code or use something totally different?
 
Sort by date Sort by votes
Slightly updated,
VBA Code: 
Sub MatchHex()

    Dim ws1 As Worksheet, ws3 As Worksheet
    Dim LRselected As Long, Lastr3 As Long
    Dim r As Long
    Dim hexToFind As String
    Dim matchRow As Variant
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    
    LRselected = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row
    Lastr3 = ws3.Cells(ws3.Rows.Count, "B").End(xlUp).Row
    
    For r = 2 To LRselected
        hexToFind = Trim(UCase(ws1.Cells(r, "K").Value))

        If hexToFind <> "" Then
            matchRow = Application.Match(hexToFind, ws3.Range("B2:B" & Lastr3), 0)

            If Not IsError(matchRow) Then
                
                ws1.Cells(r, "P").Value = ws3.Cells(matchRow + 1, "A").Value
            Else
                ws1.Cells(r, "P").Value = "Not Found"
            End If
        Else
            ws1.Cells(r, "P").Value = ""
        End If
    Next r
    
End Sub
 
Upvote 0
Sam_D_Ben said:
Sub MatchHex() Dim ws1 As Worksheet, ws3 As Worksheet Dim LRselected As Long, Lastr3 As Long Dim r As Long Dim hexToFind As String Dim matchRow As Variant Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws3 = ThisWorkbook.Sheets("Sheet3") LRselected = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row Lastr3 = ws3.Cells(ws3.Rows.Count, "B").End(xlUp).Row For r = 2 To LRselected hexToFind = Trim(UCase(ws1.Cells(r, "K").Value)) If hexToFind <> "" Then matchRow = Application.Match(hexToFind, ws3.Range("B2:B" & Lastr3), 0) If Not IsError(matchRow) Then ws1.Cells(r, "P").Value = ws3.Cells(matchRow + 1, "A").Value Else ws1.Cells(r, "P").Value = "Not Found" End If Else ws1.Cells(r, "P").Value = "" End If Next r End Sub
Click to expand...
in a flash I tried your code but get a 'Run-Time error #9' 'Subscript out of range' I'll have more time to work on it
 
Upvote 0
I've tested this sample, and it works well. Could you share your data?
1742773669022.png
 
Upvote 0
Please check this,
VBA Code: 
Lastr3 = .Range("A" & .Rows.Count).End(xlUp).Row 'presently at 30282
 
Upvote 0
Sam_D_Ben said:
Please check this,
VBA Code: 
Lastr3 = .Range("A" & .Rows.Count).End(xlUp).Row 'presently at 30282
Click to expand...

Sam_D_Ben said:
Please check this,
VBA Code: 
Lastr3 = .Range("A" & .Rows.Count).End(xlUp).Row 'presently at 30282
Click to expand...
i tried this and still get same error
i downloaded the workbook file Dropbox
excuse the number of commented out code, this is my experimental workbook. NO personal or sensitive information in it. if you need to make changes that's OK
 
Upvote 0
KDS14589 said:
i tried this and still get same error
i downloaded the workbook file Dropbox
excuse the number of commented out code, this is my experimental workbook. NO personal or sensitive information in it. if you need to make changes that's OK
Click to expand...
Sorry, my security system is flagging your file and preventing the download. I don’t mind if you could just share screenshots of the files here instead.
Or try this, would be much better - XL2BB - Excel Range to BBCode
Thank You
 
Upvote 0
Sam_D_Ben said:
Sorry, my security system is flagging your file and preventing the download. I don’t mind if you could just share screenshots of the files here instead.
Or try this, would be much better - XL2BB - Excel Range to BBCode
Thank You
Click to expand...
i tried that XL2BB before and had problems with download/install so I'm sending screen shots and code while i try that XL2BB again.

VBA Code: 
Option Explicit

Sub worksheet_activate()

With Sheet1
    .Cells.RowHeight = 16
    .Cells.ColumnWidth = 3
    .Cells.HorizontalAlignment = xlCenter
    .Cells.Font.Name = "Segoe UI"
    .Cells.Font.Color = vbBlack
    .Cells.Interior.Color = vbWhite
    .Cells.Font.Size = 12
    .Cells.Font.Bold = False
    .Cells.Font.Italic = False
    .Cells.Font.Underline = False
    .Cells.Font.Strikethrough = False
    .Cells.Font.Subscript = False
    .Cells.Font.Superscript = False
    .Cells.ClearFormats
    .Cells.Interior.Color = vbWhite
End With



''''clear
With Sheet1
    .Columns("E:G").ClearContents
    .Columns("H").Interior.Color = vbWhite
    .Columns("M:P").ClearContents
    .Columns("J").Interior.Color = vbWhite
End With

'''' last row
With Sheet1
    Dim Lastr1 As Long
    Lastr1 = .Range("C" & .Rows.Count).End(xlUp).Row    'presently at 2863

    Dim LRselected As Long
    LRselected = .Range("K" & .Rows.Count).End(xlUp).Row    'presently at 8
End With

With Sheet3
    Dim Lastr3 As Long
    Lastr3 = .Range("A" & .Rows.Count).End(xlUp).Row    'presently at 30282
End With

MsgBox "Last Row List= " & Lastr1 & vbLf & "Last Row of Select Hex= " & LRselected & vbLf & "Last Row of 30k=" & Lastr3

''''HEADERS
Cells(1, 1).EntireRow.ClearContents
With Sheet1
    With .Range("A1")   'checked
        .Value = "Checked"
        .HorizontalAlignment = xlCenter
    End With
    With .Range("B1")   'name
        .Value = "Color Name by color-name-generator.com "
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 50
    End With
    With .Range("C1")   'hex
        .Value = "Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("D1")   'R
        .Value = "R  by List Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("E1")   'G
        .Value = "G  by List Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("F1")   'B
        .Value = "B  by List Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("G1")
        .Value = "Color List"
        .ColumnWidth = 30
    End With
    With .Range("J1")
        .Value = "Color by Selected"
        .ColumnWidth = 30
    End With
    With .Range("K1")
        .Value = "Selected Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
'    With .Range("L1")   'R
'        .Value = "30k Hex"
'        .HorizontalAlignment = xlCenter
'        .ColumnWidth = 14
'    End With
    With .Range("M1")   'R
        .Value = "R  by Selected Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("N1")   'R
        .Value = "G  by Selected Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
     With .Range("O1")   'R
        .Value = "B  by Selected Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 14
    End With
    With .Range("P1")   'name
        .Value = "Color Name by 30k Hex"
        .HorizontalAlignment = xlCenter
        .ColumnWidth = 50
    End With
End With

''''Col Alingment
With Sheet1
    With .Range("B2:B" & Lastr1)   'name
        .HorizontalAlignment = xlLeft
        .IndentLevel = 1
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("C2:C" & Lastr1)   'hex
        .HorizontalAlignment = xlLeft
        .IndentLevel = 1
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("D2:D" & Lastr1)   'R
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("E2:E" & Lastr1)   'G
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("F2:F" & Lastr1)   'B
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
     With .Range("G2:G" & Lastr1)   '
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
     With .Range("J2:J" & Lastr1)   'Color by 30k
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("K2:K" & Lastr1)   'HEX by 30k
        .HorizontalAlignment = xlLeft
        .IndentLevel = 1
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("M2:M" & Lastr1)   'R by 30k
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
     With .Range("N2:N" & Lastr1)   'G by 30k
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
     With .Range("O2:O" & Lastr1)   'B by 30k
        .HorizontalAlignment = xlCenter
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    With .Range("P2:P" & Lastr1)   '30k name
        .HorizontalAlignment = xlLeft
        .IndentLevel = 1
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlack
    End With
    
End With
Dim cll As Range
For Each cll In Sheet1.Range("c2:c" & Lastr1).Rows
    cll.Offset(0, 1).Value = "=GetRGBFromHex(RC[-1],""R"")"
    cll.Offset(0, 2).Value = "=GetRGBFromHex(RC[-2],""G"")"
    cll.Offset(0, 3).Value = "=GetRGBFromHex(RC[-3],""B"")"
    cll.Offset(0, 4).Interior.Color = RGB(cll.Offset(0, 1).Value, cll.Offset(0, 2).Value, cll.Offset(0, 3).Value)
Next

For Each cll In Sheet1.Range("K2:K" & Lastr1).Rows
    If cll.Value <> "" Then
        cll.Offset(0, 2).Value = "=GetRGBFromHex(RC[-2],""R"")"
        cll.Offset(0, 3).Value = "=GetRGBFromHex(RC[-3],""G"")"
        cll.Offset(0, 4).Value = "=GetRGBFromHex(RC[-4],""B"")"
        cll.Offset(0, -1).Interior.Color = RGB(cll.Offset(0, 2).Value, cll.Offset(0, 3).Value, cll.Offset(0, 4).Value)
    End If
    If cll.Value = "" Then
        cll.Offset(0, 2).Value = ""
        cll.Offset(0, 3).Value = ""
        cll.Offset(0, 4).Value = ""
        cll.Offset(0, -1).Interior.Color = vbWhite
    End If
Next

''''30k Color NamE
'Dim CLL1 As Range
'Dim r As Long
'     For r = 2 To LRselected
'For Each CLL1 In Sheet1.Range("K2:K" & LRselected).Rows
'    If CLL1.Value <> "" Then
'         CLL1.Offset(0, 5).Value = WorksheetFunction.Index(Sheet3.Range("A2:A" & Lastr3), WorksheetFunction.Match(Sheet1.Cells(r, "K"), Sheet3.Range("B2:B" & Lastr3), 0))
'    End If
'    If CLL1.Value = "" Then
'        CLL1.Offset(0, 5).Value = ""
'    End If
'   Next
    

    
    
    
'Dim k As Integer
'
'For k = 2 To Lastr1
'
'Sheet1.Cells(k, 12).Value = WorksheetFunction.Index(Sheet3.Range("B2:B30282"), WorksheetFunction.Match(Sheet1.Cells(k, 3), Sheet1.Range("C2:C2862"), 0))
'Next k
''Dim cll3 As Range
''
''For Each cll3 In Sheet1.Range("C2:C" & Lastr1).Rows
''    If cll3.Value = Sheet3("B1:B" & Lastr3).Value Then
''        cll3.Offset(0, 9).Value = "Match"
''        End If
''    Next


'Call MatchHex



Call WsColumnAutoWidthPlus.ColWidthPlus

End Sub
Sub MatchHex()

    Dim ws1 As Worksheet, ws3 As Worksheet
    Dim LRselected As Long, Lastr3 As Long
    Dim r As Long
    Dim hexToFind As String
    Dim matchRow As Variant
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    
    LRselected = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row
    Lastr3 = ws3.Range("A" & ws3.Rows.Count).End(xlUp).Row 'presently at 30282
    
    For r = 2 To LRselected
        hexToFind = Trim(UCase(ws1.Cells(r, "K").Value))

        If hexToFind <> "" Then
            matchRow = Application.Match(hexToFind, ws3.Range("B2:B" & Lastr3), 0)

            If Not IsError(matchRow) Then
                
                ws1.Cells(r, "P").Value = ws3.Cells(matchRow + 1, "A").Value
            Else
                ws1.Cells(r, "P").Value = "Not Found"
            End If
        Else
            ws1.Cells(r, "P").Value = ""
        End If
    Next r
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
Hide rows with different values in the same column?
Replies
4
Views
135
Olov
O
I
  • Question Question
Load Listbox only if two values are present in two cells otherwise ignore & continue down the sheet
Replies
6
Views
188
ipbr21054
I
V
  • Question Question
Copy data from 1 sheet and paste in another sheet.
Replies
2
Views
251
Vasanth88ece
V
A
  • Solved
doesn't show data in listbox on form without any error in this code
Replies
6
Views
362
Abdo
A
I
  • Solved
Edit existing working code if certain condition is met
2
Replies
10
Views
153
ipbr21054
I

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top