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

Option Explicit
Dim Wb(1 To 2) As Workbook, xlText As String, S As Integer, AR()
Const 工作簿 = "查詢用"
Sub 查詢_A() '要查詢資料的活頁簿已開啟
主活頁簿
For Each Wb(2) In Workbooks '所有開啟的活頁簿
If Wb(1).Name <> Wb(2).Name Then 資料查詢
Next
置入資料
End Sub
Sub 查詢_B() '要查詢資料的活頁簿未開啟: 且與主活頁簿在同一資料夾查詢 "*工作日報表.xls" 活頁簿的資料
Dim xlFile As String, xlPath As String
主活頁簿
xlPath = Wb(1).Path & "\"
xlFile = Dir(xlPath & "*工作日報表.xls")
Wb(1).Activate
Application.ScreenUpdating = False
Do While xlFile <> ""
If Wb(1).Name <> xlFile Then
Set Wb(2) = Workbooks.Open(xlPath & xlFile)
資料查詢
Wb(2).Close False
End If
xlFile = Dir
Loop
置入資料
Application.ScreenUpdating = True
End Sub
Sub 查詢_C() '要查詢資料的活頁簿未開啟: 用視窗來選起取(指定)資料夾查詢 "*工作日報表.xls" 活頁簿的資料
Dim xlPath As String, xlFile As String
主活頁簿
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Wb(1).Path & "\"
If .Show = True Then
xlPath = .SelectedItems(1) & "\"
Else
MsgBox "沒有指定資料夾"
Exit Sub
End If
End With
xlFile = Dir(xlPath & "*工作日報表.xls")
Wb(1).Activate
Application.ScreenUpdating = False
Do While xlFile <> ""
If Wb(1).Name <> xlFile Then
Set Wb(2) = Workbooks.Open(xlPath & xlFile)
資料查詢
Wb(2).Close False
End If
xlFile = Dir
Loop
置入資料
Application.ScreenUpdating = True
End Sub
Sub 清除資料()
With Wb(1).Sheets(工作簿) '程式碼所在的活頁簿
.Range("B4").CurrentRegion.Offset(2).Clear '清除舊有資料
End With
End Sub
Private Sub 主活頁簿()
Set Wb(1) = ThisWorkbook '程式碼所在的活頁簿
'Set Wb(1 =Workbooks("工作日報表.xls") '在指定的活頁簿
xlText = Wb(1).Sheets("查詢用").TextBox1 '要搜尋的字串
S = 0
End Sub
Private Sub 資料查詢()
Dim E As Range, Ay(), xi As Integer
For Each E In Wb(2).Sheets(1).UsedRange.Rows '已使用範圍的列
If (E.Cells(1, 4) <> "" And IsNumeric(E.Cells(1, 4))) And Mid(E.Cells(1, 4), 1, Len(xlText)) = xlText Then '比對D欄中的字串
ReDim Preserve AR(S) '重新配置動態陣列變數的儲存空間。
'Preserve:選擇性引數。當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
ReDim Ay(1 To E.Cells.Count)
For xi = 1 To E.Cells.Count '將比對到的列從第1欄依序置入陣列
Ay(xi) = E.Cells(1, xi).Text
Next
AR(S) = Ay
S = S + 1 '下一個比對到的列之陣列元素索引值
End If
Next
End Sub
Private Sub 置入資料()
Dim xi As Integer
With Wb(1).Sheets(工作簿) '程式碼所在的活頁簿
If S > 0 Then
.Range("B4").CurrentRegion.Offset(2).Clear '清除舊有資料
For xi = 0 To S - 1
.Range("B5").Offset(xi).Resize(1, UBound(AR(xi))).Value = AR(xi) '依序置入比對到的列
'UBound 函數傳回 Long值，表示指定陣列某維最大可使用的陣列索引。
Next
Else
MsgBox "查無資料"
End If
End With
End Sub

複製代碼