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

lsc900707

WYS67 发表于 2018-10-8 23:36
老师：这是您写的25楼的代码，1.在指定J1为3，三个分表没有打开的情况下，点击宏按钮，显示更新结束的计算 ...

依样画葫芦的事吧：
Sub 更新1007()
     Application.ScreenUpdating = False
     Set wk = ThisWorkbook
     tms = Timer
     r1 = [g1]: r2 = [h2].Value
     If r2 <= r1 Then arr = Range("e5:j" & r1)
     ReDim brr(1 To UBound(arr), 1 To 6)
      Select Case [j1] * 1
         Case "0"
         f = False
         For Each wb In Application.Workbooks
             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "三同") Then
                 f = True
                 With wb.Sheets(1)
                     xm = .[i1]: n = .[g1]
                     m = 0
                     For i = 1 To UBound(arr)
                         If arr(i, 6) = xm Then
                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
                             For j = 1 To 5
                                 brr(m, j) = arr(i, j)
                             Next
                         End If
                     Next
                     For i = 1 To m
                         If i = 1 Then
                             brr(i, 6) = r - 4
                         Else
                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
                         End If
                     Next
                     brr(m + 1, 6) = .[c1] - brr(m, 1)
                     .Range("e5:i" & n - 4).ClearContents
                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
                 End With
             End If
         Next
         If f = False Then MsgBox "《 0 三同》" & "未打开！": Exit Sub
         Case "1"
         f = False
         For Each wb In Application.Workbooks
             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "组三") Then
                 f = True
                 With wb.Sheets(1)
                     xm = .[i1]: n = .[g1]
                     m = 0
                     For i = 1 To UBound(arr)
                         If arr(i, 6) = xm Then
                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
                             For j = 1 To 5
                                 brr(m, j) = arr(i, j)
                             Next
                         End If
                     Next
                     For i = 1 To m
                         If i = 1 Then
                             brr(i, 6) = r - 4
                         Else
                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
                         End If
                     Next
                     brr(m + 1, 6) = .[c1] - brr(m, 1)
                     .Range("e5:i" & n - 4).ClearContents
                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
                 End With
             End If
         Next
         If f = False Then MsgBox "《1 组三》" & "未打开！": Exit Sub
         Case "2"
         f = False
         For Each wb In Application.Workbooks
             If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "组六") Then
                 f = True
                 With wb.Sheets(1)
                     xm = .[i1]: n = .[g1]
                     m = 0
                     For i = 1 To UBound(arr)
                         If arr(i, 6) = xm Then
                             m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
                             For j = 1 To 5
                                 brr(m, j) = arr(i, j)
                             Next
                         End If
                     Next
                     For i = 1 To m
                         If i = 1 Then
                             brr(i, 6) = r - 4
                         Else
                             brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
                         End If
                     Next
                     brr(m + 1, 6) = .[c1] - brr(m, 1)
                     .Range("e5:i" & n - 4).ClearContents
                     .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
                 End With
             End If
         Next
         If f = False Then MsgBox "《2 组六》" & "未打开！": Exit Sub
         Case "3"
              f = False
              For Each wb In Application.Workbooks
                If wb.Name <> ThisWorkbook.Name And InStr(wb.Name, "三同, 组三, 组六") Then
                    f = True
                    With wb.Sheets(1)
                        xm = .[i1]: n = .[g1]
                        m = 0
                        For i = 1 To UBound(arr)
                            If arr(i, 6) = xm Then
                                m = m + 1: r = Application.Match(xm, wk.Sheets(1).[j:j], 0)
                                For j = 1 To 5
                                    brr(m, j) = arr(i, j)
                                Next
                            End If
                        Next
                        For i = 1 To m
                            If i = 1 Then
                                brr(i, 6) = r - 4
                            Else
                                brr(i, 6) = brr(i, 1) - brr(i - 1, 1)
                            End If
                        Next
                        brr(m + 1, 6) = .[c1] - brr(m, 1)
                        .Range("e5:i" & n - 4).ClearContents
                        .Range("e5").Resize(n - 4, UBound(brr, 2)) = brr
                    End With
                End If
            Next
            If f = False Then MsgBox "所有分表均未打开！": Exit Sub
          Case Else
             Exit Sub
     End Select
     Application.ScreenUpdating = True
     MsgBox "更新完成!，耗时" & Format(Timer - tms, "0.000s")
End Sub

lsc900707

如果有很多表，则把  With wb.Sheets(1)
改成   With wb.Sheets("总表")

lss001

既然要更新各分表中的总表
把→wb.Activate
改为→wb.Activate: Sheets("总表").Activate

其实不必增加→总表
把→wb.Activate
改为→wb.Activate: Sheets("" & Mid(wbName(w), 3, 2) & "").Activate

WYS67

lsc900707 发表于 2018-10-9 13:06
依样画葫芦的事吧：
Sub 更新1007()
     Application.ScreenUpdating = False

老师：明明打开了所有分表，可为什么老是提示“所有分表均未打开” ，无法运行？

WYS67

lss001 发表于 2018-10-9 10:01
既然要更新各分表中的总表
把→wb.Activate
改为→wb.Activate: Sheets("总表").Activate

老师：这次完全正确，能够显示计算结果到对应的分表！

lsc900707

WYS67 发表于 2018-10-9 13:34
老师：明明打开了所有分表，可为什么老是提示“所有分表均未打开” ，无法运行？

网络太差，没下载附件测试。晚点看看。

WYS67

lsc900707 发表于 2018-10-9 14:45
网络太差，没下载附件测试。晚点看看。

那就先谢谢老师了！