- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2012-4-26 16:11
| 只看該作者
回復 1# jackson7015 - 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
|
|
發表於 2012-4-26 09:16
| 
