yosi 發問時間: 電腦與網際網路軟體 · 1 0 年前

Excel篩選巨集增加功能2

再請教:

篩選巨集(上次幫我完成後半部的巨集)再加上這回的比對搜尋巨集的功能,二合為一個可精選工作表的巨集。

一、以篩選巨集執行後的結果(sheet2)從第四列開始,第一欄是列次欄 (記錄列編號),第二欄是資料欄 (記錄儲存格內容),等二個要件為準,再跟資料夾下下的工作表裏的 "D1" 與 "B1"相比對,如果相符合的,就把這個工作表複製過來,排在(sheet2)之後。

請注意:"D1" 是列次欄 (記錄列編號), "B1"是資料欄 (記錄儲存格內容),與篩選巨集的排列有點左右相反。

1 個解答

評分
  • 最佳解答

    Public gm_origin_path As String

    Public gm_xls() As String

    Public gm_find_string As String

    Public gm_thisworkbook_name As String

    Public gm_find_sh As String

    Public gm_search_count As Integer '搜尋的數量

    Public Sub main_process主要作業()

    Call read_setup

    Call find_xls

    If UBound(gm_xls) = 0 Then

    Call MsgBox("該目錄下:" & gm_origin_path & ",無xls檔案", vbCritical)

    Exit Sub

    End If

    Call open_xls

    End Sub

    Private Sub read_setup()

    Dim i As Integer

    Dim j As Integer

    Dim wk_a As Variant

    Dim wk_sh_name As String

    gm_find_sh = ""

    '960713

    'wk_sh_name = Sheets("搜尋設定區").Range("c1")

    wk_sh_name = "Sheets2"

    i = 0

    wk_range1 = Sheets(wk_sh_name).Range("a3")

    wk_range2 = Sheets(wk_sh_name).Range("b3")

    Do Until wk_range1 = ""

    If InStr(wk_range1, ",") <> 0 Then

    GoSub deal_string

    Else

    gm_find_sh = gm_find_sh & ";" & wk_range1 & "," & wk_range2

    End If

    i = i + 1

    wk_range1 = Sheets(wk_sh_name).Range("a3").Offset(i, 0)

    wk_range2 = Sheets(wk_sh_name).Range("b3").Offset(i, 0)

    Loop

    gm_find_sh = ";" & gm_find_sh & ";" '形成這種字串 ";1,2;1,3;2,4;"

    gm_origin_path = ThisWorkbook.Path & "\"

    gm_thisworkbook_name = ThisWorkbook.Name

    Exit Sub

    deal_string:

    wk_a = Split(wk_range1, ",")

    For j = 0 To UBound(wk_a)

    gm_find_sh = gm_find_sh & ";" & wk_a(j) & "," & wk_range2

    Next j

    Return

    End Sub

    Private Sub find_xls() '讀取xls檔名,將xls檔名放入gm_xls()內

    Dim wk_file_name As String

    ReDim gm_xls(0)

    wk_file_name = Dir(gm_origin_path)

    Do Until wk_file_name = ""

    If Right(wk_file_name, 4) = ".xls" And wk_file_name <> ThisWorkbook.Name Then

    ReDim Preserve gm_xls(UBound(gm_xls) + 1)

    gm_xls(UBound(gm_xls)) = wk_file_name

    End If

    wk_file_name = Dir

    Loop

    End Sub

    Private Sub open_xls() '開啟xls檔案

    Dim wk_workbook As Workbook

    Dim i As Integer

    On Error GoTo fail_exit

還有問題?馬上發問,尋求解答。