给代码增加按J1指定数字代号，更新数据到对应分表的功能。

WYS67

lsc900707 发表于 2018-10-6 10:19
你一会儿说打开更新，一会儿又说不打开更新，晕死！

老师：您误会了。我说的是：比如，在J1指定“0”，需要更新《0 三同》的数据，可是《0 三同》却忘了打开，或打开的是其他分表，这时点击宏按钮，就会弹出下面的出错警告！   想把弹出的这个警告框置换成：显示“《0 三同》未打开”错误提醒的文本框。如此而已。

lss001

在→Case "0"，Case "1"，Case "2"，Case "3"
各处上面下面添加如下代码！

Case "0"
For Each wa In Workbooks
If wa.Name = "0 三同.xlsm" Then

Next
MsgBox "" & "0 三同.xlsm" & "未打开！": Exit Sub
Case "1"
For Each wa In Workbooks
If wa.Name = "1 组三.xlsm" Then

Next
MsgBox "" & "1 组三.xlsm" & "未打开！": Exit Sub
Case "2"
For Each wa In Workbooks
If wa.Name = "2 组六.xlsm" Then

Next
MsgBox "" & "2 组六.xlsm" & "未打开！": Exit Sub
Case "3"

WYS67

lss001 发表于 2018-10-6 12:43
在→Case "0"→Case "1"→Case "2"
下面各添加一行代码→
If wb = "" Then Msgbox "该工作薄未打开！": ...

谢谢老师帮忙！今明两天的鲜花全部奉上！

lsc900707

lss001 发表于 2018-10-6 12:43
更正！！？
在→Case "0"，Case "1"，Case "2"，Case "3"
各处上面下面添加如下代码！

有测试过你的写法和代码相吻合吗？测试过完整代码的可行性吗？

lsc900707

WYS67 发表于 2018-10-6 10:32
老师：您误会了。我说的是：比如，在J1指定“0”，需要更新《0 三同》的数据，可是《0 三同》却忘了打开 ...

1. Sub 更新1007()
   
2.     Application.ScreenUpdating = False
   
3.     Set wk = ThisWorkbook
   
4.     tms = Timer
   
5.     r1 = [g1]: r2 = [h2].Value
   
6.     If r2 <= r1 Then arr = Range("e5:j" & r1)
   
7.     ReDim brr(1 To UBound(arr), 1 To 6)
   
8.      Select Case [j1] * 1
   
9.         Case "0"
   
10.         f = False
    
11.         For Each wb In Application.Workbooks
    
12.             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "三同") Then
    
13.                 f = True
    
14.                 With wb.Sheets(1)
    
15.                     xm = .[i1]: n = .[g1]
    
16.                     m = 0
    
17.                     For i = 1 To UBound(arr)
    
18.                         If arr(i, 6) = xm Then
    
19.                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
    
20.                             For j = 1 To 5
    
21.                                 brr(m, j) = arr(i, j)
    
22.                             Next
    
23.                         End If
    
24.                     Next
    
25.                     For i = 1 To m
    
26.                         If i = 1 Then
    
27.                             brr(i, 6) = r - 4
    
28.                         Else
    
29.                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
    
30.                         End If
    
31.                     Next
    
32.                     brr(m + 1, 6) = .[c1] - brr(m, 1)
    
33.                     .Range("e5:i" & n - 4).ClearContents
    
34.                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
    
35.                 End With
    
36.             End If
    
37.         Next
    
38.         If f = False Then MsgBox "《 0 三同》" & "未打开！": Exit Sub
    
39.         Case "1"
    
40.         f = False
    
41.         For Each wb In Application.Workbooks
    
42.             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "组三") Then
    
43.                 f = True
    
44.                 With wb.Sheets(1)
    
45.                     xm = .[i1]: n = .[g1]
    
46.                     m = 0
    
47.                     For i = 1 To UBound(arr)
    
48.                         If arr(i, 6) = xm Then
    
49.                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
    
50.                             For j = 1 To 5
    
51.                                 brr(m, j) = arr(i, j)
    
52.                             Next
    
53.                         End If
    
54.                     Next
    
55.                     For i = 1 To m
    
56.                         If i = 1 Then
    
57.                             brr(i, 6) = r - 4
    
58.                         Else
    
59.                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
    
60.                         End If
    
61.                     Next
    
62.                     brr(m + 1, 6) = .[c1] - brr(m, 1)
    
63.                     .Range("e5:i" & n - 4).ClearContents
    
64.                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
    
65.                 End With
    
66.             End If
    
67.         Next
    
68.         If f = False Then MsgBox "《1 组三》" & "未打开！": Exit Sub
    
69.         Case "2"
    
70.         f = False
    
71.         For Each wb In Application.Workbooks
    
72.             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "组六") Then
    
73.                 f = True
    
74.                 With wb.Sheets(1)
    
75.                     xm = .[i1]: n = .[g1]
    
76.                     m = 0
    
77.                     For i = 1 To UBound(arr)
    
78.                         If arr(i, 6) = xm Then
    
79.                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
    
80.                             For j = 1 To 5
    
81.                                 brr(m, j) = arr(i, j)
    
82.                             Next
    
83.                         End If
    
84.                     Next
    
85.                     For i = 1 To m
    
86.                         If i = 1 Then
    
87.                             brr(i, 6) = r - 4
    
88.                         Else
    
89.                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
    
90.                         End If
    
91.                     Next
    
92.                     brr(m + 1, 6) = .[c1] - brr(m, 1)
    
93.                     .Range("e5:i" & n - 4).ClearContents
    
94.                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
    
95.                 End With
    
96.             End If
    
97.         Next
    
98.         If f = False Then MsgBox "《2 组六》" & "未打开！": Exit Sub
    
99.         Case "3"
    
100.             For Each wb In Application.Workbooks
     
101.                 If wb.Name <> ThisWorkbook.Name Then
     
102.                     With wb.Sheets(1)
     
103.                         xm = .[i1]: n = .[g1]
     
104.                         m = 0
     
105.                         For i = 1 To UBound(arr)
     
106.                             If arr(i, 6) = xm Then
     
107.                                 m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
     
108.                                 For j = 1 To 5
     
109.                                     brr(m, j) = arr(i, j)
     
110.                                 Next
     
111.                             End If
     
112.                         Next
     
113.                         For i = 1 To m
     
114.                             If i = 1 Then
     
115.                                 brr(i, 6) = r - 4
     
116.                             Else
     
117.                                 brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
     
118.                             End If
     
119.                         Next
     
120.                         brr(m + 1, 6) = .[c1] - brr(m, 1)
     
121.                          .Range("e5:i" & n - 4).ClearContents
     
122.                          .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
     
123.                     End With
     
124.                 End If
     
125.              Next
     
126.          Case Else
     
127.             Exit Sub
     
128.     End Select
     
129.     Application.ScreenUpdating = True
     
130.     MsgBox "更新完成!，耗时" & Format(Timer - tms, "0.000s")
     
131. End Sub

复制代码

WYS67

lsc900707 发表于 2018-10-6 18:04

版主老师：就是这样！运算速度又快了不少！谢谢您的耐心帮助！今日没花了，容后奉上！

WYS67

lss001 发表于 2018-10-6 12:43
在→Case "0"，Case "1"，Case "2"，Case "3"
各处上面下面添加如下代码！

非常感谢老师这一段时间对我的莫大帮助！
下面是别人为我写的自定义函数LENGMA和LENGHAO。公式的计算结果虽然正确，但运行速度慢得要死，才4万多行数据，就爬不动了。想麻烦您再重新创建一个区域数组公式输入的LENGMA公式。详细情况和原代码都在下面的附件里。
      冷码【表一】 要求：
1.函数用途：两位数冷码查询。
2.函数名称：LENGMA(数据区域)
3.公式举例说明  ：选定C5:C100000区域，输入区域数组公式 =LENGMA(B5:B100000).
4.公式类型：区域数组公式。

冷号【表二】 要求：
1.函数用途：一位数冷号查询。
2.函数名称：LENGHAO(数据区域)
3.公式举例说明  ：选定E5:E100000区域，输入区域数组公式 =LENGHAO(C5:C100000).
4.公式类型：区域数组公式。
冷码和冷号.zip (532.8 KB, 下载次数: 2)

2018-10-7 11:20 上传

点击文件名下载附件

WYS67

恳请老师们帮忙！

小花鹿

WYS67 发表于 2018-10-7 10:46
非常感谢老师这一段时间对我的莫大帮助！
下面是别人为我写的自定义函数LENGMA和LENGHAO。公式的计算结 ...

这个问题应该另外发帖                                                                                                           

WYS67

小花鹿 发表于 2018-10-7 11:38
这个问题应该另外发帖                                                                               ...

谢谢老师提醒！