使用列表框選擇選擇並轉到單元格

Question

enter image description here我有一個工作簿，其中包含針對S & P 500中的每個行業部門的不同工作表，即Tech，Energy，Ect。我創建了一個帶有兩個列表框的用戶窗體，允許用戶首先選擇一個扇區，然後選擇該扇區獨有的子扇區。列表框工作得很好，但現在我想創建一個命令按鈕，用於選擇用戶選擇的任何子扇區，並使活動工作表中包含該子扇區的第一行數據成爲活動單元格。

Private Sub GoToSectorButton_Click() 
'Declare variables 
Dim SubIndustry As String 
Dim IntRow As Integer 

'Set list box value equal to the variable 
SubIndustry = lstSubIndustry.Value 

'Locate the first occurance of the Sub Industry 
IntRow = 3 

'Select the row that contains 
ActiveSheet.cell(SubIndustry).Select 

End Sub 


Private Sub UserForm_Initialize() 

'declare variable 
Dim shtIndustry As Worksheet 
'shows Industries in lstIndustry that aren't the first set of sets 
For Each shtIndustry In Application.Workbooks("VBA_Finance_Project_KEZE6983.xlsm").Worksheets 
    If shtIndustry.Name <> "Welcome" And shtIndustry.Name <> "Name Or Sector" And shtIndustry.Name <> "Name" And shtIndustry.Name <> "Sector" And shtIndustry.Name <> "Filter" And shtIndustry.Name <> "Master" Then 

     lstIndustry.AddItem (shtIndustry.Name) 

    End If 
Next shtIndustry 

'select default list box item 
lstIndustry.ListIndex = 0 

End Sub 

Private Sub lstIndustry_Click() 

'declare variables 
Dim strSI As String, rngData As Range, rngCell As Range, shtSubIndustry As Worksheet 

'clear list box 
lstSubIndustry.Clear 

'Save relevant worksheets to a vaiable so that we can use the vaiable in the rest of the program as a shortcut 
Set shtSubIndustry = Application.Workbooks("VBA_Finance_Project_KEZE6983.xlsm").Worksheets(lstIndustry.ListIndex + 5) 

'activate worksheet clicked 
shtSubIndustry.Activate 

'assign address of Industry data to rngData variable 
Set rngData = Application.Workbooks("VBA_Finance_Project_KEZE6983.xlsm").ActiveSheet.Range("A3").CurrentRegion 

'assign Column heading to srtSI variable 
strSI = "GICS Sub Industry" 

'Add the Sub Industry 
For Each rngCell In rngData.Columns(14).Cells 
    If rngCell.Value <> strSI And rngCell.Value <> "" Then 
     lstSubIndustry.AddItem rngCell.Value 
     strSI = rngCell.Value 
    End If 
Next rngCell 

'select default list box item 
lstSubIndustry.ListIndex = 0 


End Sub 

Answer 1

您應該遍歷包含subIndustry值的行。如果子行業名稱在列「A」中。

喜歡的東西（警告：未經測試）

Dim c as Range 
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
For Each c In Range("A1:A" + LastRow).Cells 
    If c.Value == subIndustry Then 
    c.parent.activate 'Activate worksheet 
    c.select 
    Exit 
    End If 
Next 

Answer 2

下面的功能我用我加入的邏輯，它幫助識別匹配的記錄行數。

這個函數很靈活，可以匹配多個條件。

在你的情況，

ActiveWindow.ScrollRow = getRowMultiMatch(Array(Range("M:M"), Range("N:N")), 1, Array(Sector,Subsector)) 


Function getRowMultiMatch(ByVal arrRange As Variant, ByVal startMatchOnRow As Single, ByVal arrMatchValue As Variant) As Single 
'Return 0 if unable to match 
'arrRange = Array of Source Range 
'startMatchOnRow = 1 
'arrMatchValue = Array of Value need to Match 

Dim i, nRow, nStartRow, nLastRow As Single 
Dim nRng, dataRng, nColRng As Range 
Dim nWSD As Worksheet 
Dim nValue As Variant 

     Set nColRng = arrRange(0) 
     Set nWSD = nColRng.Parent 

     'Start and Last (Row Number) Help define when to stop looping 
     nStartRow = nColRng.Cells(1).Row 
     If startMatchOnRow > nStartRow Then nStartRow = startMatchOnRow 
     nLastRow = nColRng.Cells(nColRng.Cells.Count).Row 

Retry: 
     'Sizing nRng 
     Set nRng = Intersect(nColRng.EntireColumn, nWSD.Range(nWSD.Rows(nStartRow), nWSD.Rows(nLastRow))) 

     nValue = arrMatchValue(0) 
     If IsNumeric(nValue) = False Then 
      nValue = CStr(nValue) 
      nValue = Replace(nValue, "*", "~*") 
     End If 

     'Matching First Item 
     If IsError(Application.Match(nValue, nRng, 0)) Then 
      getRowMultiMatch = 0 
      Exit Function 
     Else 
      nRow = Application.Match(nValue, nRng, 0) 
      'Looping to Check if all values are match 
      For i = 1 To UBound(arrMatchValue) 'Start loop from 2nd Item 
       Set dataRng = Intersect(nWSD.Rows(nStartRow + nRow - 1), arrRange(i).EntireColumn) 
       If StrComp(dataRng.Value, arrMatchValue(i)) <> 0 Then 
        'Not Match 
        'Resize nRng then Retry 
        GoTo NotMatch 
       Else 
        'Matched 
       End If 
      Next i 
      'All Matched 
      getRowMultiMatch = nStartRow + nRow - 1 
      Exit Function 
NotMatch: 
      nStartRow = nStartRow + nRow 
      If nStartRow > nLastRow Then 
       Exit Function 
      Else 
       GoTo Retry 
      End If 
     End If 

End Function