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

WYS67

老师们：根据《00 总表》N14的原代码，新增按J1指定的数字代号，更新数据到对应分表的功能。


J1指定的4个数字，就相当于一个电路分线开关，按下哪个按钮就会点亮哪个房间里的灯泡；按“3”时，则点亮所有房间的灯泡。

说明和要求在N5:N9里，恳请老师们照此完善代码。

按J1指定的代号更新数据到对应的分表.zip (996.83 KB, 下载次数: 42)

2018-10-5 00:17 上传

点击文件名下载附件

lsc900707

Sub 更新1005()
    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)
    p = ThisWorkbook.Path & "\"
     Select Case [j1] * 1
        Case "0"
            With Workbooks.Open(p & "0 三同.xlsm").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
        Case "1"
            With Workbooks.Open(p & "1 组三.xlsm").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
        Case "2"
            With Workbooks.Open(p & "2 组六.xlsm").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
        Case "3"
            f = Dir(p & "*.xlsm")
            Do While f <> ""
                If f <> ThisWorkbook.Name Then
                    Set wb = Workbooks.Open(p & f)
                    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
                    wb.Close True
                End If
                f = Dir
            Loop
         Case Else
            Exit Sub
    End Select
    Application.ScreenUpdating = True
    MsgBox Format(Timer - tms, "0.000s")
End Sub

lsc900707

测试附件：

WYS67

lsc900707 发表于 2018-10-5 08:00
测试附件：

老师：下载后测试了一下，代码完全实现了按J1指定数字更新分表的目的，运行速度也很快！

    美中不足的是：当三个分表也都处于打开状态【这样可以很方便数据更新后分类查看比较】下，指定J1为“3”，点击《00 总表》里的更新按钮后，会只保留一个分表处于打开状态，其余两个会自动关闭。

   能不能只更新数据，而不让已经打开的分表自动关闭？需要关闭时，可以采取手动方式。

lsc900707

只要把那句wb.close true注释掉就可以。

lsc900707

代码倒数第10行。

WYS67

lsc900707 发表于 2018-10-5 08:56
只要把那句wb.close true注释掉就可以。

版主老师：去掉wb.close true后，三个分表不再自动关闭了，却出现了新问题：指定J1为“3”时，点击更新按钮，显示更新结束，但三个分表没有刷新输入的数据；指定J1为“1”时，点击按钮后，《1 组三》里的数据也无法刷新；但指定J1为“0”和“2”时，可以刷新《0 三同》和《2 组六》数据；

  怪了！指定J1为偶数【0、2】时可以刷新数据，奇数【1、3】时却不能刷新数据。您看问题怎么解决？

WYS67

恳请老师帮忙解决：

指定J1为偶数【0、2】时可以刷新数据，奇数【1、3】时却不能刷新数据的问题。

WYS67

lsc900707 发表于 2018-10-5 08:58
代码倒数第10行。

去掉wb.close true后，三个分表更新不再自动关闭了，却出现了---指定J1为偶数【0、2】时可以刷新数据，奇数【1、3】时却不能刷新数据。

请老师帮忙解决！

lsc900707

WYS67 发表于 2018-10-5 15:37
去掉wb.close true后，三个分表更新不再自动关闭了，却出现了---指定J1为偶数【0、2】时可以刷新数据，奇 ...

我测试都没问题，要不你清空数值试试！
还有一个前提，工作簿是不需要你手工打开的！