組合框VB​​A Excel使用其他工作表中的數據庫

Question

我希望你們都能幫助我嘗試爲這種任務獲得一些VBA代碼。讓我們說我有這樣的表1：

，我在表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