none
listfillrange in combobox

    Question

  •  

    greetings!

     

    hi. i got a problem here. i want to put a visual basic to change the listfillrange properties of combobox. it goes like this:

    if the cell A1 is equal to B1, listfillrange in combobox properties will have a list of "factory1: if A1=C1, listfillrange=factory2 and so on. pls help me to have a complete code

     

    hoping,

    rajed

    Wednesday, July 30, 2008 2:17 AM

Answers

  • The code below is just for reference...

     

    Code Snippet

    Sub MAIN()
    Dim PT As Range
    Dim i As Long
        With ActiveSheet
            setNames .Range("a6")
            Set PT = .Range("b1")
            i = 1
            Do Until PT = ""
                If .Range("a1").Value = PT.Value Then
                    On Error Resume Next
                    .ComboBox1.ListFillRange = ThisWorkbook.Names("factory" & i).RefersToRange.Address
                    If Err.Number = 1004 Then
                        MsgBox "not defined name: factory" & i
                    ElseIf Err.Number <> 0 Then
                        MsgBox "unexpected error: " & Err.Description
                    End If
                    On Error GoTo 0
                End If
                i = i + 1
                Set PT = PT.Offset(0, 1)
            Loop
        End With
    End Sub

    Sub setNames(theTopLeft As Range)
    Dim theName As Name
    Dim nameStr As String
    Dim theRng As Range
    Dim i As Long
        Application.DisplayAlerts = False
        theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
                        Bottom:=False, Right:=False
        Application.DisplayAlerts = True
        For Each theName In ThisWorkbook.Names
            With theName.RefersToRange
                For i = .Cells.Count To 1 Step -1
                    If .Cells(i) <> "" Then Exit For
                Next
            End With
            If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
        Next
    End Sub

     

     

    Here is an Example.

    http://www.box.net/shared/qupocbb40k

     

    Wednesday, July 30, 2008 4:34 AM
  • No, it can be automatic.

    Please copy the code to Sheet1 module

     

    Code Snippet

    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address = "$A$1" Then MAIN
    End Sub

     

     

    Wednesday, July 30, 2008 10:56 AM
  •  rajed wrote:

     

    I'd tried it. It's great. Wow!!!!

    my problem now is that my factory list is at the other worksheet. Let's say sheet2. And the list of factory1 is in colunm A, factory2 is in column D, it is also applicable. What part of the code wil be changed?

     

     

    rajed

    The code is changed like ...

     

    Code Snippet

    Sub MAIN()
    Dim PT As Range
    Dim i As Long
    Dim theRng As Range
        With ActiveSheet
            Set PT = .Range("b1")
            i = 1
            Do Until PT = ""
                If .Range("a1").Value = PT.Value Then
                    On Error Resume Next
                    Set theRng = ThisWorkbook.Names("factory" & i).RefersToRange
                    .ComboBox1.ListFillRange = theRng.Worksheet.Name & "!" & theRng.Address
                    If Err.Number = 1004 Then
                        MsgBox "not defined name: factory" & i
                    ElseIf Err.Number <> 0 Then
                        MsgBox "unexpected error: " & Err.Description
                    End If
                    On Error GoTo 0
                End If
                i = i + 1
                Set PT = PT.Offset(0, 1)
            Loop
        End With
    End Sub

    'this procedure is just for run once
    'you run this procedure as the first time or while your factory data changed
    'or put the procedure below in Thisworkbook module to run it when this file is opened
    '        Private Sub Workbook_Open()
    '            setNames
    '        End Sub
    Sub setNames()
    Dim theName As Name
    Dim nameStr As String
    Dim theRng As Range
    Dim i As Long, j As Long
        'Application.DisplayAlerts = False
        With Sheets("Sheet2").Rows(1)
            j = .Cells(.Cells.Count).End(xlToLeft).Column
            For i = 1 To j
                If .Cells(i).Value <> "" Then
                    Set theRng = .Worksheet.Range(.Cells(i), .Cells(i).End(xlDown))
                End If
                theRng.CreateNames Top:=True, Left:=False, _
                                Bottom:=False, Right:=False
            Next
        End With
        'Application.DisplayAlerts = True
    End Sub

     

     

    Thursday, July 31, 2008 3:01 AM
  • see the fig,

    http://k7opxg.bay.livefilestore.com/y1p-GY4ilakq5h52vD8lIfj0js8W5VWyCKQpnosEp02n4ImZmtMKMgHkx_zkU-jCy7dtPlDoCd-UlA/MS01.jpg

    double clicks the ThisWorkbook module in your VBE , then paste the code on the code window.

    Thursday, July 31, 2008 7:19 AM

All replies

  • The code below is just for reference...

     

    Code Snippet

    Sub MAIN()
    Dim PT As Range
    Dim i As Long
        With ActiveSheet
            setNames .Range("a6")
            Set PT = .Range("b1")
            i = 1
            Do Until PT = ""
                If .Range("a1").Value = PT.Value Then
                    On Error Resume Next
                    .ComboBox1.ListFillRange = ThisWorkbook.Names("factory" & i).RefersToRange.Address
                    If Err.Number = 1004 Then
                        MsgBox "not defined name: factory" & i
                    ElseIf Err.Number <> 0 Then
                        MsgBox "unexpected error: " & Err.Description
                    End If
                    On Error GoTo 0
                End If
                i = i + 1
                Set PT = PT.Offset(0, 1)
            Loop
        End With
    End Sub

    Sub setNames(theTopLeft As Range)
    Dim theName As Name
    Dim nameStr As String
    Dim theRng As Range
    Dim i As Long
        Application.DisplayAlerts = False
        theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
                        Bottom:=False, Right:=False
        Application.DisplayAlerts = True
        For Each theName In ThisWorkbook.Names
            With theName.RefersToRange
                For i = .Cells.Count To 1 Step -1
                    If .Cells(i) <> "" Then Exit For
                Next
            End With
            If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
        Next
    End Sub

     

     

    Here is an Example.

    http://www.box.net/shared/qupocbb40k

     

    Wednesday, July 30, 2008 4:34 AM
  •  

    thank you very much!!!

     

    rajed

     

    p.s.

    it is really necessary to have a command button?

    could we have it automatically?

    Wednesday, July 30, 2008 9:39 AM
  • No, it can be automatic.

    Please copy the code to Sheet1 module

     

    Code Snippet

    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address = "$A$1" Then MAIN
    End Sub

     

     

    Wednesday, July 30, 2008 10:56 AM
  •  

    I'd tried it. It's great. Wow!!!!

    my problem now is that my factory list is at the other worksheet. Let's say sheet2. And the list of factory1 is in colunm A, factory2 is in column D, it is also applicable. What part of the code wil be changed?

     

     

    rajed

    Wednesday, July 30, 2008 11:55 PM
  •  rajed wrote:

     

    I'd tried it. It's great. Wow!!!!

    my problem now is that my factory list is at the other worksheet. Let's say sheet2. And the list of factory1 is in colunm A, factory2 is in column D, it is also applicable. What part of the code wil be changed?

     

     

    rajed

    The code is changed like ...

     

    Code Snippet

    Sub MAIN()
    Dim PT As Range
    Dim i As Long
    Dim theRng As Range
        With ActiveSheet
            Set PT = .Range("b1")
            i = 1
            Do Until PT = ""
                If .Range("a1").Value = PT.Value Then
                    On Error Resume Next
                    Set theRng = ThisWorkbook.Names("factory" & i).RefersToRange
                    .ComboBox1.ListFillRange = theRng.Worksheet.Name & "!" & theRng.Address
                    If Err.Number = 1004 Then
                        MsgBox "not defined name: factory" & i
                    ElseIf Err.Number <> 0 Then
                        MsgBox "unexpected error: " & Err.Description
                    End If
                    On Error GoTo 0
                End If
                i = i + 1
                Set PT = PT.Offset(0, 1)
            Loop
        End With
    End Sub

    'this procedure is just for run once
    'you run this procedure as the first time or while your factory data changed
    'or put the procedure below in Thisworkbook module to run it when this file is opened
    '        Private Sub Workbook_Open()
    '            setNames
    '        End Sub
    Sub setNames()
    Dim theName As Name
    Dim nameStr As String
    Dim theRng As Range
    Dim i As Long, j As Long
        'Application.DisplayAlerts = False
        With Sheets("Sheet2").Rows(1)
            j = .Cells(.Cells.Count).End(xlToLeft).Column
            For i = 1 To j
                If .Cells(i).Value <> "" Then
                    Set theRng = .Worksheet.Range(.Cells(i), .Cells(i).End(xlDown))
                End If
                theRng.CreateNames Top:=True, Left:=False, _
                                Bottom:=False, Right:=False
            Next
        End With
        'Application.DisplayAlerts = True
    End Sub

     

     

    Thursday, July 31, 2008 3:01 AM
  •  i can't transfer it to my worksheet. I can't find the ThisWorkbook module.

    Thursday, July 31, 2008 6:55 AM
  • see the fig,

    http://k7opxg.bay.livefilestore.com/y1p-GY4ilakq5h52vD8lIfj0js8W5VWyCKQpnosEp02n4ImZmtMKMgHkx_zkU-jCy7dtPlDoCd-UlA/MS01.jpg

    double clicks the ThisWorkbook module in your VBE , then paste the code on the code window.

    Thursday, July 31, 2008 7:19 AM
  •  

    bravo!!!!!!!!

     

    EUrika, EUrika!!! I got it, I got it!!!!

     

    thank you very much!!!

     

     

    rajed

    Thursday, July 31, 2008 11:56 PM