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

WYS67 · 发表于 2018-10-7 13:44

lss001 发表于 2018-10-7 12:47
Function LENGMA(rng As Range)
Dim a, b, c, d, i, x, y, ar, br
ar = rng: ReDim br(1 To UB ...

老师：什么原因？在C5:C100000里输入{ =LENGMA(B5:B100000) 公式后，计算结果全部显示#VALUE!错误。

lss001 · 发表于 2018-10-7 14:14

本帖最后由 lss001 于 2018-10-7 14:31 编辑

楼上已经更新代码！！！

WYS67 · 发表于 2018-10-7 15:24

本帖最后由 WYS67 于 2018-10-7 16:14 编辑

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

老师：显示的计算结果不正确。下面截图左边是您写的代码的计算结果，右边才是我想要的结果

详细定义和规则在http://club.excelhome.net/forum. ... 011&pid=9679173 里

WYS67 · 发表于 2018-10-8 23:36

本帖最后由 WYS67 于 2018-10-9 03:17 编辑

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

老师：这是您写的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"
         For Each wb In Application.Workbooks
            If wb.Name <> ThisWorkbook.Name Then
                  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
      Case Else
         Exit Sub
End Select
Application.ScreenUpdating = True
MsgBox "更新完成!，耗时" & Format(Timer - tms, "0.000s")
End Sub

WYS67 · 发表于 2018-10-9 04:28

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

老师：还得麻烦您完善您写的代码：先看截图：当各个分表工作簿里只有一个工作表时，无论表名是什么，点击按钮后都能更新数据。

但是拆分《00 总表》数据到几个对应的分表工作簿，就是为了减少单表运算时间。每个分表工作簿里会有好多个工作表，这时点击按钮，就会显示错误。

不得已，只能在《0 三同》、《1 组三》和《2 组六》里各自辟出《总表》工作表，专门用于存放从《00 总表》拆分后的数据。
在各个分表工作簿里，这个《总表》无法确定排在那个位置。

请老师修改代码，能够使《00 总表》拆分的数据，只能存放在《0 三同》、《1 组三》和《2 组六》三个分表工作簿的《总表》里。

请看附件：

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

WYS67 · 发表于 2018-10-9 05:21

lss001 发表于 2018-10-7 12:47
←_←←_←

老师：刚才代码发错了，这个里面才是您写的代码。当初想得不周到，三个分类工作簿里只有一个工作表，实际应用中，一个分类工作簿里需要不同表名的许多工作表，代码无法选择要显示结果的工作表，所以才会出错。
现在给三个分类工作簿，各自都命名了一个《总表》，麻烦修改代码，让计算结果都显示在各自对应的《总表》里。

WYS67 · 发表于 2018-10-9 11:35

本帖最后由 WYS67 于 2018-10-9 11:43 编辑

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

把→wb.Activate
改为→wb.Activate: Sheets(“& Mid(wb.Name(w), 3 ,2) & "").Activate ，提示：编辑错误，语法错误。

WYS67 · 发表于 2018-10-9 12:05

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

无论把需要更新分类工作表改成总表，把→wb.Activate 改为→wb.Activate: Sheets(“总表").Activate，

还是把需要更新分类工作表改成对应的三同、组三、组六，把→wb.Activate ，改为→wb.Activate: Sheets(“& Mid(wb.Name(w), 3 ,2) & "").Activate ，代码都无法运行。

lss001 · 发表于 2018-10-9 12:33

本帖最后由 lss001 于 2018-10-9 13:25 编辑

楼上已经更正！

WYS67 · 发表于 2018-10-9 13:01

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

老师修改为 wb.Activate: Sheets("" & Mid(wb.Name(w), 3 ,2) & "").Activate 后，运行代码时弹出警告：

		自动登录	找回密码
密码			免费注册

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