|
本帖最后由 盼哥 于 2018-10-28 17:39 编辑
- <blockquote><div class="blockcode"><blockquote>Option Explicit
- Dim i&, j&
- Sub picupData()
- '按指定期序提取数据
- '专业VBA开发:+QQ21416904
- '作者:涂运盼,专写优秀代码!
- '日期:2018-10-27
- Application.ScreenUpdating = False '关闭屏幕刷新
-
- Dim fName$
- fName = ThisWorkbook.Path & "\00 总表.xlsm"
-
- Dim sBook As Workbook '源工作薄
- If FileIsOpen("00 总表.xlsm") Then '判断"00 总表.xlsm"是否打开?
- Set sBook = Workbooks("00 总表.xlsm")
- Else
- If Not IsFileExists(fName) Then
- MsgBox fName & "不存在!"
- End
- End If
- Set sBook = Workbooks.Open(fName) '没有打开则打开
- End If
-
-
-
- Dim sArr
-
- With sBook
- sArr = .Sheets(1).UsedRange '将源数据装入sarr数组
- '.Close False '关闭不保存
- End With
-
- Dim maxRow '最大数据区域
- With ThisWorkbook.ActiveSheet
- maxRow = .[H1]
- End With
- maxRow = maxRow - 4 '减去4行标题
-
- Dim tArr '定义目标数据
- ReDim tArr(1 To maxRow, 1 To 6) '初始化目标数据大小
-
- Dim defN& '默认期序
- Dim startN& '开始期序
- Dim endN& '结果期序
-
- With ThisWorkbook.ActiveSheet '赋值
- defN = .[C2]
- startN = .[F2]
- endN = .[H2]
- End With
-
- j = 1
- Select Case True
-
- Case startN <> 0 And endN <> 0 '指定期序匀有数字
-
- For i = 5 To UBound(sArr)
- If (sArr(i, [H1].Column) >= startN) And (sArr(i, [H1].Column) <= endN And sArr(i, [J1].Column) <> "") Then
- tArr(j, 1) = sArr(i, [E1].Column)
- tArr(j, 2) = sArr(i, [F1].Column)
- tArr(j, 3) = sArr(i, [G1].Column)
- tArr(j, 4) = sArr(i, [H1].Column)
- tArr(j, 5) = sArr(i, [I1].Column)
- tArr(j, 6) = sArr(i, [J1].Column)
- j = j + 1
- End If
-
- If j > maxRow Then GoTo 100:
- Next i
-
- Case endN = 0 And startN <> 0 '只有最小期序有数字
- For i = 5 To UBound(sArr)
- If sArr(i, [H1].Column) = startN And sArr(i, [J1].Column) <> "" Then
- tArr(j, 1) = sArr(i, [E1].Column)
- tArr(j, 2) = sArr(i, [F1].Column)
- tArr(j, 3) = sArr(i, [G1].Column)
- tArr(j, 4) = sArr(i, [H1].Column)
- tArr(j, 5) = sArr(i, [I1].Column)
- tArr(j, 6) = sArr(i, [J1].Column)
- j = j + 1
- End If
-
- If j > maxRow Then GoTo 100:
- Next i
- Case startN = 0 And endN = 0 '指定期序都没数字
- For i = 5 To UBound(sArr)
- If sArr(i, [H1].Column) = defN And sArr(i, [J1].Column) <> "" Then
- tArr(j, 1) = sArr(i, [E1].Column)
- tArr(j, 2) = sArr(i, [F1].Column)
- tArr(j, 3) = sArr(i, [G1].Column)
- tArr(j, 4) = sArr(i, [H1].Column)
- tArr(j, 5) = sArr(i, [I1].Column)
- tArr(j, 6) = sArr(i, [J1].Column)
- j = j + 1
- End If
-
- If j > maxRow Then GoTo 100:
- Next i
-
- End Select
- 100:
- ThisWorkbook.ActiveSheet.[E5].Resize(UBound(tArr), UBound(tArr, 2)) = tArr
-
- Application.ScreenUpdating = True '打开屏幕刷新
- [A5].Select
- MsgBox "完成!"
-
-
- End Sub
- Function IsFileExists(ByVal strFileName As String) As Boolean
- '某文件是否存在
- If Dir(strFileName, 16) <> Empty Then
- IsFileExists = True
- Else
- IsFileExists = False
- End If
- End Function
- Function FileIsOpen(x)
-
- '本函数判断文件是否打开,已经打开返回True,未打开返回False。
- '用法FileIsOpen(文件完整路径),x为字符串类型
-
- On Error Resume Next
- Dim xs As Workbook
- Set xs = Workbooks(x)
- If Err.Number = 0 Then
- FileIsOpen = True
- Else
- FileIsOpen = False
- End If
- Set xs = Nothing
- Err.Clear
- End Function
复制代码
|
评分
-
1
查看全部评分
-
|