麻辣家族討論版版 - Powered by Discuz! Board

Sub 選股與同產業()
Dim 代碼別 As String, 產業別 As Range
代碼別 = InputBox("請輸入您欲篩選之股票代碼 (Stock No.)" & vbCrLf & "(例如：1101、1203、1234、或 1439 等) ", "基本資料") ' 彈出輸入視窗
If 代碼別 = "" Then Exit Sub
With Sheets("對手同產業")
.AutoFilterMode = False ' 取消自動篩選 (回復原始篩選前內容)
Set 產業別 = Sheets("對手同產業").[B:B].Find(代碼別, , , 1)
If Not 產業別 Is Nothing Then
.Range("A1").AutoFilter FIELD:=6, Criteria1:=產業別.Offset(, 4).Value ' 自動篩選
End If
End With
With Sheets("選股報表")
.AutoFilterMode = False ' 取消自動篩選 (回復原始篩選前內容)
Set 產業別 = Sheets("選股報表").[A:A].Find(代碼別, , , 1)
If Not 產業別 Is Nothing Then
.Range("A1").AutoFilter FIELD:=4, Criteria1:=產業別.Offset(, 3).Value ' 自動篩選
End If
End With
End Sub

複製代碼

Option Explicit
Sub Ex()
Dim i As Integer, Msg As String, D As Object, E As Variant, Rng As Range
With Sheets("對手同產業")
If .AutoFilterMode Then '有使用自動篩選(AutoFilter)
'If .AutoFilterMode = True Then '有使用自動篩選(AutoFilter)
With .AutoFilter.Filters(1)
'** Filter物件的集合，代表自動篩選範圍中的所有篩選
'** On 屬性如果指定的篩選已開啟，則為 True。唯讀 Boolean
If .On Then Msg = Mid(.Criteria1, 2) '**確定[代碼]篩選有指定條件
End With
End If
If Msg = "" Then
MsgBox .Name & " 代碼沒指定 !!"
Else
Set D = CreateObject("SCRIPTING.DICTIONARY") '**字典物件
With .Range("B:B").SpecialCells(xlCellTypeVisible) '** 資料篩選後可見的儲存格
For Each E In .Cells
If E = "" Then Exit For '** 沒有資料終止迴圈
If E.Row > 1 Then D(E.Value) = "" '** 字典物件中加入代碼
Next
End With
With Sheets("選股報表")
If .AutoFilterMode Then .AutoFilterMode = False '**有使用自動篩選(AutoFilter)
.Cells.EntireRow.Hidden = False '** 取消所有列的隱藏
Set Rng = .Rows("3:" & .Range("A1").End(xlDown).Row) '** 設定資料的範圍
Rng.EntireRow.Hidden = True '** 範圍的列隱藏
For Each E In Rng.Rows ' ** 範圍列的迴圈
If D.exists(E.Cells(1, 1).Value) Then '**字典物件的key值有代碼
E.EntireRow.Hidden = False '** 取消列的隱藏
D.Remove (E.Cells(1, 1).Value) '**Remove 方法把成員從 Collection 物件中移除。
If D.Count = 0 Then Exit For ' '** Count 物件中成員的總數
End If
Next
End With
MsgBox Msg & " 選股報表 Ok"
End If
End With
End Sub

複製代碼