按要求修改VBA过程的J列公式代码

WYS67

lsc900707 发表于 2018-9-30 19:27
代码未经测试，附件供参考：

版主老师：还得再次麻烦您按104楼的方法，在下面您写的代码基础上，增加J1指定的数字为所要更新数据的分表选项，具体说明在附件的《00 总表》里。鲜花会多多奉上！
河南快三.zip (996.69 KB, 下载次数: 1)

2018-10-4 17:17 上传

点击文件名下载附件

lsc900707

WYS67 发表于 2018-10-2 20:52
终于弄明白了。过程加载宏后仍然无法调用，必须要有下面这段代码，才能被其他工作表里调用。

Sub Auto ...

不知道你说的啥情况。

lsc900707

WYS67 发表于 2018-10-4 17:19
版主老师：还得再次麻烦您按104楼的方法，在下面您写的代码基础上，增加J1指定的数字为所要更新数据的分 ...

有时间我看看，这两天有事要忙。

WYS67

lsc900707 发表于 2018-10-4 22:04
有时间我看看，这两天有事要忙。

好的。谢谢老师！

lsc900707

WYS67 发表于 2018-10-4 22:45
好的。谢谢老师！

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 发表于 2018-10-4 22:45
好的。谢谢老师！

测试附件：