最新消息

[公告2014/05/30] 如有需要將部落格中,任何一篇文章的程式碼使用在商業用途,請與我聯繫。

[公告2015/04/26] Line版的 iInfo程式與投資應用 群組已上線想加入的朋友們,請先查看 "入群須知" 再與我聯繫 Line : aminwhite5168,加入請告知身分與回答 "入群須知" 的問題。

[公告2018/04/22] 台北 Python + Excel VBA 金融資訊爬蟲課程,課程如網頁內容 金融資訊爬蟲班:台北班 Python 金融資訊爬蟲、EXCEL VBA 金融資訊爬蟲

[公告2019/01/08] 請注意:我再次重申,部落格文章的程式碼,是要提供各位參考與學習,一旦網頁改版請自行修改,別要求東要求西要我主動修改,你們用我寫東西賺錢了、交差了,請問有分我一杯羹嗎?既然賺錢沒分我,請問有什麼理由要求我修改,如果沒能力改,就花錢來找我上課。

[公告2019/12/01] 若各位有 Excel VBA 案子開發需求,歡迎與我聯繫,可接案處理。

[公告2020/05/22] 頁面載入速度慢,起因為部分JS來源(alexgorbatchev.com)失效導致頁面載入變慢,目前已做調整,請多見諒。

2020年3月19日 星期四

Excel VBA 下拉選單切換連動 (2)

繼前一篇 Excel VBA 下拉選單切換連動 (1),內容一樣是Excel VBA下拉選單選的連動,只是這是要用資料驗證中的清單功能來做,這次的功能是第一個combobox選擇年月,第二個combobox將以選到的年月顯示當年度到年底剩下的月份,依舊使用 篩選 + 事件來組合。
在ThisWorkbooks加入
Private Sub Workbook_Open()
    日期產生
    第一層清單產生
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = "資料顯示" Then
        If Target.Address = "$A$1" Then
            第二層清單產生
        ElseIf Target.Address = "$F:$F" Then
            If Workbooks(1).Sheets(1).Cells(Rows.count, "F").End(xlUp).Row = 1 Then
                Workbooks(1).Sheets(1).Cells(1, 2).Value = ""
            End If
        End If
        Debug.Print Target.Address
    End If
End Sub
在Module1中加入
Sub 日期產生()
    Sheets(2).Cells(1, 1) = "日期"

    For i = 2 To 13
        Sheets(2).Cells(i, 1) = Format(DateAdd("m", i - 1, DateSerial(Year(Date), 0, 1)), "ee/mm")
    Next
End Sub

Sub 第一層清單產生()
    Dim listcount1 As Integer
    
    Workbooks(1).Sheets(1).Columns(5).Clear
    
    With Workbooks(1).Sheets(2)
        .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbooks(1).Sheets(1).Range("E1"), Unique:=True
    End With

    With Workbooks(1).Sheets(2)
        .Range(.Cells(2, "A").Address, .Cells(Rows.count, "A").End(xlUp).Address).Name = "日期1"
    End With
    
    '設定"資料驗證"中的清單
    With Workbooks(1).Sheets(1).Range("A1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="=日期1"
    End With
    Workbooks(1).Sheets(1).Cells(1, 1).Value = Workbooks(1).Sheets(2).Cells(2, "A").Value
    Workbooks(1).Sheets(1).Cells(1, 2).Value = Workbooks(1).Sheets(1).Cells(2, "F").Value
End Sub

Sub 第二層清單產生()
    Dim listcount1 As Integer
    
    Workbooks(1).Sheets(1).Columns(6).Clear
    
    過濾日期

    With Workbooks(1).Sheets(1)
        .Range(.Cells(2, "F").Address, .Cells(Rows.count, "F").End(xlUp).Address).Name = "日期2"
    End With
    
    '設定"資料驗證"中的清單
    With Workbooks(1).Sheets(1).Range("B1")
        .Clear
        With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                 Operator:=xlBetween, Formula1:="=日期2"
        End With
        Workbooks(1).Sheets(1).Cells(1, 2).Value = Workbooks(1).Sheets(1).Cells(2, "F").Value
    End With
End Sub

Sub 過濾日期()
    Dim tmp, line
    Dim i As Integer, j As Integer, count As Integer, column As Integer
    
    With Workbooks(1).Sheets(2)
        column = .Cells(1, Columns.count).End(xlToLeft).column
        With .UsedRange
  
            .AutoFilter Field:=.Cells(1, "A").column, Criteria1:=">=" & Sheets(1).Cells(1, 1)
            
            '選出符合條件的資料
            Set tmp = .Resize(.Rows.count).SpecialCells(xlCellTypeVisible)
            count = 1
            For Each line In tmp.Areas
                For i = 1 To line.Rows.count
                    For j = 1 To 1
                        'Debug.Print line(i, j).Value
                        Sheets(1).Cells(count, "F").Value = line(i, j).Value
                    Next
                    count = count + 1
                Next
            Next
        End With
        
        '關閉篩選
        .AutoFilterMode = False
    End With
End Sub
畫面。

檔案連結

沒有留言:

張貼留言