loop thru refrences and return offset cell value when found

[pwwato]

Hi Guys
Thanks in advance fro taking the time to look at this much appreciated.

I have a worksheet called sites, each site has a ref no found in column A and be in this coloumn multiple times because each site also has a unit number found in column B the reason for this is some sites have multiple units or blocks,
A B

CO177	CO177/CO
CO179	CO179/CO
CY183	CY183/CY
DR186	DR186/DR
GA326	GA326/TR1
GA326	GA326/TR2
GA326	GA326/TR3
GA326	GA326/TR4
GO200	GO200/GO
GR202	GR202/GR

<tbody>
</tbody>

So as yo can see some are only there once while some like GA326 are there more because that site is made up of 4 blocks GA326/TR1 & 2 & 3 &4.

What I am trying to do is create vba code that will find all unit references (B) from a site ref (A) and return a msgbox for each giving me the ref and row number related to them, this is the code I am using so far and it almost works but not fully, it correctly finds the first unit ref but then keep putting that ref in the next msgbox,

If I type G0200 it works ok gives me one message box (A) x 1 as there is only one site ref in A and gives me correct unit ref GO200/GO
But if I put GA326 in it gives me 4 msgboxes which is right (A) X 4 but only gives me first Unit ref in (B) msgbox always has GA326/TR1 . not started doing the row part until I get the ref side working so heres the code I have so far Hope someone can help.

Private Sub TEST_Click()
Dim msgval As String
Dim refno As String


Application.Workbooks("yesdatav2.xlsm").Sheets("sites").Activate


msgval = InputBox("ENTER REF", "YES")

' Get the range of values
Dim rg As Range
Set rg = Sheet4.Range("A1:A1000")

' Create the dictionary
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

' Fill the dictionary
Dim cell As Range
For Each cell In rg
dict(cell.Value) = cell.Offset(0, 1).Value
Next

' Perform the Lookup
For Each cell In rg

If (cell.Value) = msgval Then
refno = Application.WorksheetFunction.VLookup(msgval, Sheet4.Range("SITES"), 2, False)
MsgBox refno
End If
Next

End Sub

Hope some one can help!!<strike></strike>

<strike></strike>

 

[Fluff]

If you want to use a dictionary try

Private Sub TEST_Click()
    Dim msgval As String
    Dim refno As String
    
    
    Application.Workbooks("yesdatav2.xlsm").Sheets("sites").Activate
    
    
    msgval = InputBox("ENTER REF", "YES")
    
    ' Get the range of values
    Dim rg As Range
    Set rg = Sheet4.Range("A1:A1000")
    
    ' Create the dictionary
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Fill the dictionary
    Dim Cl As Range
    With dict
        For Each Cl In rg
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Cl.Offset(, 1).Value
            Else
                .Item(Cl.Value) = .Item(Cl.Value) & vbLf & Cl.Offset(, 1).Value
            End If
        Next Cl
        MsgBox .Item(msgval)
    End With
   
End Sub

Although another approach would be

Sub TEST_Click2()
    Dim msgval As String
    Dim rg As Range
    Dim Cl As Range
    Dim Msg As String

    msgval = InputBox("ENTER REF", "YES")

    For Each Cl In Sheet5.Range("A1:A28")
        If Cl.Value = msgval Then
            Msg = Msg & vbLf & Cl.Offset(, 1).Value & " Row " & Cl.Row
        End If
    Next Cl
    MsgBox Msg
    


End Sub

 

[pwwato]

Wow thanks for that using bottom code as you already sorted row out for me..
One problem I'm going to have is I need each ref and row to be separate msgbox for each, the reason behind this is the msgbox will be replaced with code when I write it to add tab strip to userform using unit ref as name and then adding further detail from that unit ref. row to add detail to textboxes on that tab page tab page, if that makes sense.

But much appreciate how you have helped so far, thanks

 

[Fluff]

Is this what you mean

Sub TEST_Click2()
    Dim msgval As String
    Dim rg As Range
    Dim Cl As Range
    Dim Msg As String

    msgval = InputBox("ENTER REF", "YES")

    For Each Cl In Sheet5.Range("A1:A28")
        If Cl.Value = msgval Then
            MsgBox Cl.Offset(, 1).Value & " Row " & Cl.Row
        End If
    Next Cl

End Sub

 

[pwwato]

Yes thanks fluff that's just what iv done replied before checking code and adjusting I'm now trying to add pages to multipage with page name as ref, and then add textboxes to that page with row source and offset as values, so multipage, page name becomes GA326/TR1 and values from that row, column 3,4,5,6 go in to new textboxes on that page. etc

I will get there in end but any help is appreciated, bit of a novice at this and set myself a massive project to do FOOL? but a stubborn one

 

[Fluff]

In that case you're probably better off using a dictionary. Put this in the userform module

Private Sub UserForm_Initialize()

    Dim MPage As MSForms.MultiPage
    Dim i As Long
    Dim Cl As Range
    Dim refno As String
    Dim rg As Range

    Set MPage = Me.Controls.Add("forms.multipage.1", "MyPage")
    MPage.Top = 0
    MPage.Left = 0
    MPage.Width = Me.Width
    MPage.Height = Me.Height
    
'    Application.Workbooks("yesdatav2.xlsm").Sheets("sites").Activate
    
    
    ' Get the range of values
    Set rg = Sheet12.Range("B1:B10")
    
    ' Fill the dictionary
    i = 0
    With CreateObject("Scripting.Dictionary")
        For Each Cl In rg
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                If i < 2 Then
                    MPage.Pages(i).Caption = Cl.Value
                    i = i + 1
                Else
                    MPage.Pages.Add (Cl.Value)
                End If
            End If
        Next Cl
    End With
End Sub

 

[pwwato]

thanks for the input fluff managed to get the desired effect doing this although not sure if it will work in long run as I want the info to be updatable back to sheet tried to post my form on here to give you a better idea but cant seem to be able to do that. basically the form consists of a contact form that is fully working and I have a separate multipage on this form with sites and lifts pages , the effect I'm trying to get is when a contact is selected, the multipage 1 with sites and lifts page pulls info from there relevant sheets and populates another multipage on each of the sites and lifts page with the relevant info for each site and lift for that customer. if that make sence. here's the code that works for the site part ( that you have helped with many thanks) although as I have said I wonder if I can do it this way and make it updatable back to sheet.

Private Sub TEST_Click()
Application.ScreenUpdating = False
Application.Workbooks("yesdatav2.xlsm").Sheets("SITES").Activate
Application.Workbooks("yesdatav2.xlsm").ActiveSheet.Select
Dim msgval As String
Dim rg As Range
Dim Cl As Range
Dim Msg As String
Dim MSGR As String
Dim I As Integer

msgval = REF.Value 'InputBox("ENTER REF", "YES")
For Each Cl In Sheet4.Range("A1:A500")
If Cl.Value = msgval Then
Msg = Cl.Offset(, 1).Value & " Row " & Cl.Row
MSGR = Cl.Offset(, 1).Value

MultiPage2.Pages(0).SNAME.Value = Cl.Offset(, 3).Value
MultiPage2.Pages(0).SADD1.Value = Cl.Offset(, 8).Value
MultiPage2.Pages(0).SADD2.Value = Cl.Offset(, 9).Value
MultiPage2.Pages(0).SCITY.Value = Cl.Offset(, 10).Value
MultiPage2.Pages(0).SPCODE.Value = Cl.Offset(, 11).Value
MultiPage2.Pages(0).SCONTACT.Value = Cl.Offset(, 5).Value
MultiPage2.Pages(0).SPHONE.Value = Cl.Offset(, 6).Value
MultiPage2.Pages(0).SEMAIL.Value = Cl.Offset(, 7).Value
MultiPage2.Pages(0).SINFOS.Value = Cl.Offset(, 13).Value

Me.MultiPage2.Pages.Add (MSGR)
MultiPage2.Pages(0).Controls.Copy
MultiPage2.Pages(MSGR).Paste


'MsgBox Msg
End If
Next Cl
'MultiPage2.Pages(0).Visible = False I keep this page basically as a template for other pages.controls and then hide it once done although I do need to find a way of removing the extra pages once contact changed
End Sub

 

[Fluff]

Not quite sure what you are trying to achieve, but as it's a very long time since I last created userforms, I'd recomend starting a new thread if you need any further help.

 

[pwwato]

ok thanks for your help so far

 

[Fluff]

Glad to be of help