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

Question

我希望大家都能帮助我尝试为此类任务获取一些VBA代码。 让我们说我在工作表1中有这个：

我在工作表2中有数据库（可以在此处下载文件）：

如果单击工作表1中的组合框，则会出现工作表2中的公司列表。 如果我选择例如USA，那么CITY和ASSET VALUE列中的单元格将相应地自动更改（在本例中为Boston和89,826,717.71）。 当我选择在CITY列中有多个选项的COMPANY时，任务将变得更加困难，例如XYZ在CITY列中具有三个选项：西雅图，印第安纳州和洛杉矶。 我在互联网上阅读了许多文章和帖子，但似乎没有任何效果。 我正在使用Excel 2010，如果在座的人可以提供任何帮助，我将不胜感激。

Answer 1

样本文件下载链接样本文件
代码：

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