提取符合指定期序的《00 总表》【总表】E:J列的所有相关数据

盼哥

BUG已经修正，你再调试下

1. Option Explicit
   
2. Dim i&, j&, k&
   
3. Sub picupData()
   
4.     '按指定期序提取数据
   
5.     '专业VBA开发：+QQ21416904
   
6.     '作者：涂运盼，专写优秀代码！
   
7.     '日期：2018-10-27
   
8.     Application.ScreenUpdating = False '关闭屏幕刷新
   
9.    
   
10.     Dim fName$
    
11.     fName = ThisWorkbook.Path & "\00 总表.xlsm"
    
12.    
    
13.     Dim sBook As Workbook                   '源工作薄
    
14.     If FileIsOpen("00 总表.xlsm") Then              '判断"00 总表.xlsm"是否打开？
    
15.         Set sBook = Workbooks("00 总表.xlsm")
    
16.     Else
    
17.         If Not IsFileExists(fName) Then
    
18.             MsgBox fName & "不存在！"
    
19.             End
    
20.         End If
    
21.         Set sBook = Workbooks.Open(fName)           '没有打开则打开
    
22.     End If
    
23.         
    
24.    
    
25. 
    
26.    
    
27. 
    
28.     Dim sArr
    
29.    
    
30.     With sBook.Sheets(1)
    
31.         sArr = .Range("e5:j" & .Cells(2, "h"))             '将源数据装入sarr数组
    
32.         '.Close False                            '关闭不保存
    
33.     End With
    
34.    
    
35.     Dim maxRow      '最大数据区域
    
36. 
    
37.     With ThisWorkbook.ActiveSheet
    
38.         maxRow = .[h1]
    
39.     End With
    
40.     maxRow = maxRow - 4         '减去4行标题
    
41.    
    
42.     Dim tArr        '定义目标数据
    
43.     ReDim tArr(1 To maxRow, 1 To 6)     '初始化目标数据大小
    
44.    
    
45.     Dim defN&   '默认期序
    
46.     Dim startN& '开始期序
    
47.     Dim endN&   '结果期序
    
48.    
    
49.     With ThisWorkbook.ActiveSheet   '赋值
    
50.         defN = .[c2]
    
51.         startN = .[f2]
    
52.         endN = .[h2]
    
53.     End With
    
54.         
    
55.     j = 1
    
56.     Select Case True
    
57.         
    
58.         Case startN <> 0 And endN <> 0      '指定期序匀有数字
    
59.             
    
60.             For i = 1 To UBound(sArr)
    
61.                 If sArr(i, 4) >= startN And sArr(i, 4) <= endN Then
    
62.                     For k = 1 To 6
    
63.                         tArr(j, k) = sArr(i, k)
    
64.                     Next k
    
65.                     j = j + 1
    
66.                 End If
    
67.                
    
68.                 If j > maxRow Then GoTo 100:
    
69.             Next i
    
70.             
    
71.         Case endN = 0 And startN <> 0       '只有最小期序有数字
    
72.             For i = 1 To UBound(sArr)
    
73.                 If sArr(i, 4) = startN Then
    
74.                     For k = 1 To 6
    
75.                         tArr(j, k) = sArr(i, k)
    
76.                     Next k
    
77.                     j = j + 1
    
78.                 End If
    
79.                
    
80.                 If j > maxRow Then GoTo 100:
    
81.             Next i
    
82. 
    
83.         Case startN = 0 And endN = 0       '指定期序都没数字
    
84.             For i = 1 To UBound(sArr)
    
85.                 If sArr(i, 4) = defN Then
    
86.                     For k = 1 To 6
    
87.                         tArr(j, k) = sArr(i, k)
    
88.                     Next k
    
89.                     j = j + 1
    
90.                 End If
    
91.                
    
92.                 If j > maxRow Then GoTo 100:
    
93.             Next i
    
94.         
    
95.     End Select
    
96. 
    
97. 100:
    
98.     ThisWorkbook.ActiveSheet.[e5].Resize(UBound(tArr), UBound(tArr, 2)) = tArr
    
99.    
    
100.     Application.ScreenUpdating = True '打开屏幕刷新
     
101.     [A5].Select
     
102.     MsgBox "完成！"
     
103.    
     
104.    
     
105. End Sub
     
106. 
     
107. Function IsFileExists(ByVal strFileName As String) As Boolean
     
108.     '某文件是否存在
     
109.     If Dir(strFileName, 16) <> Empty Then
     
110.         IsFileExists = True
     
111.     Else
     
112.         IsFileExists = False
     
113.     End If
     
114. End Function
     
115. Function FileIsOpen(x)
     
116.    
     
117.     '本函数判断文件是否打开，已经打开返回True，未打开返回False。
     
118.     '用法FileIsOpen(文件完整路径)，x为字符串类型
     
119.    
     
120.     On Error Resume Next
     
121.     Dim xs As Workbook
     
122.     Set xs = Workbooks(x)
     
123.         If Err.Number = 0 Then
     
124.            FileIsOpen = True
     
125.         Else
     
126.            FileIsOpen = False
     
127.         End If
     
128.     Set xs = Nothing
     
129.     Err.Clear
     
130. End Function
     

复制代码

WYS67

lss001 发表于 2018-10-27 08:10
楼上已经更新代码！

老师：再次【多得都数不清次数了】麻烦您关注一下http://club.excelhome.net/thread-1443025-1-1.html，仿照前些时您写的WENLENG自定义函数的模式，创建这个关于SHENGKE的自定义函数。

WYS67

lss001 发表于 2018-10-26 22:56
Sub 按指定期序提取相关数据()
Dim ar, br, i&, j&, k&, x&, y&, h1, h2, f2,c2
    f2 = Cells(2, "f"): ...

老师：请看右边截图：C1的数据源最后行号是5968。当H1指定的最大行号为10252，大于C1的最后行号5968时，E5969:J10252就会显示#N/A错误！怎样把#N/A屏蔽为空白？恳请老师帮忙解决！