使用其他工作表中的数据库组合框VB​​A Excel

Question

我希望你们能够帮助我尝试为这类任务获取一些VBA代码。让我们说我在表1中有这个：

我在Sheet 2中有数据库（该文件可以下载here）：

如果单击工作表1中的组合框，将显示工作表2中的列表COMPANY。如果我选择，例如美国，那么列CITY和ASSET VALUE中的单元格将自动相应更改（在本例中为Boston和89,826,717.71）。当我选择在CITY列中有多个选项的COMPANY时，任务变得更加困难，例如XYZ在CITY列中有三个选项：西雅图，印第安纳和洛杉矶。 我在网上看过很多文章和帖子，但似乎没什么用。我正在使用Excel 2010，如果有人在这里可以提供任何帮助，我将非常感激。

Answer 1

示例文件下载链接Sample File
代码：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ctgCount, UniqueCount As Long
Dim subCategory() As String
Dim subItems As String
Dim myItems, ValidationFormula As String
Dim ArrayItemCount As Long
Dim UniqueItemMatch As Boolean

myItems = ""

    If Not Application.Intersect(Target, Range("C3:C12")) Is Nothing Then
        If Target.Value = "" Then
            Target.Offset(0, 1).Clear
            Exit Sub
        End If

    ctgCount = Application.WorksheetFunction.CountIf(Sheet2.Range("C3:C22"), Target.Value) - 1
    ReDim subCategory(ctgCount)

        For Each cel In Sheets("Sheet2").Range("C3:C22")
            UniqueItemMatch = False
         If cel.Value = Target.Value Then
            For i = 0 To ctgCount
                  If cel.Offset(0, 1).Value = subCategory(i) Then
                      UniqueItemMatch = True
                      Exit For
                  Else
                      UniqueItemMatch = False
                  End If
            Next i

            If UniqueItemMatch = False Then
              UniqueCount = 0
                For j = 0 To UBound(subCategory())
                    If subCategory(j) <> "" Then UniqueCount = UniqueCount + 1
                Next j
                subCategory(UniqueCount) = cel.Offset(0, 1).Value
            End If
          End If
        Next cel

        For k = 0 To UBound(subCategory())
            If subCategory(k) <> "" Then myItems = myItems & ", " & subCategory(k)
            ValidationFormula = Mid(Trim(myItems), 2, Len(Trim(myItems)) - 1)
        Next k

        Target.Offset(0, 1).Select
        Selection.Clear
        With Selection.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=ValidationFormula
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If

'************** For 2nd sub Items ***************************************************************

      If Not Application.Intersect(Target, Range("D3:D12")) Is Nothing Then
        If Target.Value = "" Then
            Target.Offset(0, 1).Clear
            Exit Sub
        End If

    ctgCount = Application.WorksheetFunction.CountIf(Sheet2.Range("D3:D22"), Target.Value) - 1
    ReDim subCategory(ctgCount)

        For Each cel In Sheets("Sheet2").Range("D3:D22")
            UniqueItemMatch = False
         If cel.Value = Target.Value Then
            For i = 0 To ctgCount
                  If cel.Offset(0, 1).Value = subCategory(i) Then
                      UniqueItemMatch = True
                      Exit For
                  Else
                      UniqueItemMatch = False
                  End If
            Next i

            If UniqueItemMatch = False Then
              UniqueCount = 0
                For j = 0 To UBound(subCategory())
                    If subCategory(j) <> "" Then UniqueCount = UniqueCount + 1
                Next j
                subCategory(UniqueCount) = cel.Offset(0, 1).Value
            End If
          End If
        Next cel

        For k = 0 To UBound(subCategory())
            If subCategory(k) <> "" Then myItems = myItems & ", " & subCategory(k)
            ValidationFormula = Mid(Trim(myItems), 2, Len(Trim(myItems)) - 1)
        Next k

        Target.Offset(0, 1).Select
        Selection.Clear
        With Selection.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=ValidationFormula
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If
End Sub