給下面的代码，添加保留源工作表E:I列原有数字格式的功能

玉阳山人

0.zip (1.39 MB, 下载次数: 3)

2024-7-9 21:38 上传

点击文件名下载附件

代码如下：


Sub 按J1更新分表()
sj = Timer
    Application.ScreenUpdating = False
    Dim WbName, wa, wb, ar, br, i&, j&, r&, s&, m&, n&, v&, w&, x&, y&
    Set wa = ThisWorkbook:  s = [h2]: ar = Range("e5:j" & s)
    WbName = Array("0 三同.xlsm", "1 组三.xlsm", "2 组六.xlsm")
    If Cells(1, "J") >= 0 And Cells(1, "J") < 3 Then
        x = Cells(1, "J"): y = x
        ElseIf Cells(1, "J") = 3 Then x = 0: y = Cells(1, "J") - 1
        Else: MsgBox "J1输入有误！": Exit Sub
    End If
    For w = x To y
    ThisWorkbook.Activate
    If Cells(1, "J") = 3 Then Workbooks.Open (ThisWorkbook.Path & "\" & WbName(w))
        For Each wb In Workbooks
            ReDim br(1 To UBound(ar), 1 To 6)
            If wb.Name = WbName(w) Then
                wb.Activate: Sheets("总表").Activate
                With Sheets("总表")
                    v = .[i1]: n = .[h1]: m = 0
                    For i = 1 To UBound(ar)
                        If ar(i, 6) = v Then
                            m = m + 1
                            r = Application.Match(v, wa.Sheets("总表").Range("j5:j" & s), 0)
                            For j = 1 To 5: br(m, j) = ar(i, j): Next
                        End If
                    Next
                    For i = 1 To m
                        If i = 1 Then br(i, 6) = r Else br(i, 6) = br(i, 1) - br(i - 1, 1)
                    Next
                    br(m + 1, 6) = .[c1] - br(m, 1)
                    Range(.Cells(5, "e"), .Cells(n, "j")).ClearContents
                    .Cells(5, "e").Resize(m + 1, 6) = br
                    Erase br
                    wb.Save: GoTo t
                End With
            End If
        Next
        MsgBox "" & WbName(w) & "未打开！"
t:      Next
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
MsgBox "运行时间：" & Timer - sj & " 秒"
End Sub


这是个按《00 总表》J列指定数值0，1，2，复制粘贴E:I列对应行数据到《0 三同》，《1 组三》，《2 组六》的VBA过程。

由于《00 总表》E列是数值格式，F:I列是文本格式；而复制粘贴的目标工作簿《0 三同》，《1 组三》，《2 组六》的E:H列则是数值格式，导致提取的数据与源工作簿《00 总表》不一致，无法进行下一步计算。

希望老师们：在上面代码合适的地方，添加复制粘贴到目标工作簿《0 三同》，《1 组三》，《2 组六》E:I列的符合条件的所有数据，保留《00 总表》E:I列原有数字格式的代码。

     谢谢

ynzsvt

1. Sub 按J1更新分表()
   
2. sj = Timer
   
3.     Application.ScreenUpdating = False
   
4.     Dim WbName, wa, wb, ar, br, i&, j&, r&, s&, m&, n&, v&, w&, x&, y&
   
5.     Set wa = ThisWorkbook:  s = [h2]: ar = Range("e5:j" & s)
   
6.     WbName = Array("0 三同.xlsm", "1 组三.xlsm", "2 组六.xlsm")
   
7.     If Cells(1, "J") >= 0 And Cells(1, "J") < 3 Then
   
8.         x = Cells(1, "J"): y = x
   
9.         ElseIf Cells(1, "J") = 3 Then x = 0: y = Cells(1, "J") - 1
   
10.         Else: MsgBox "J1输入有误！": Exit Sub
    
11.     End If
    
12.     For w = x To y
    
13.     ThisWorkbook.Activate
    
14.     If Cells(1, "J") = 3 Then Workbooks.Open (ThisWorkbook.Path & "" & WbName(w))
    
15.         For Each wb In Workbooks
    
16.             ReDim br(1 To UBound(ar), 1 To 6)
    
17.             If wb.Name = WbName(w) Then
    
18.                 wb.Activate: Sheets("总表").Activate
    
19.                 With Sheets("总表")
    
20.                     v = .[i1]: n = .[h1]: m = 0
    
21.                     For i = 1 To UBound(ar)
    
22.                         If ar(i, 6) = v Then
    
23.                             m = m + 1
    
24.                             r = Application.Match(v, wa.Sheets("总表").Range("j5:j" & s), 0)
    
25. '                            只改变了下一句，如果还不行，对下一句分段。
    
26.                             For j = 1 To 5: br(m, j) = "'" & ar(i, j): Next
    
27.                         End If
    
28.                     Next
    
29.                     For i = 1 To m
    
30.                         If i = 1 Then br(i, 6) = r Else br(i, 6) = br(i, 1) - br(i - 1, 1)
    
31.                     Next
    
32.                     br(m + 1, 6) = .[c1] - br(m, 1)
    
33.                     Range(.Cells(5, "e"), .Cells(n, "j")).ClearContents
    
34.                     .Cells(5, "e").Resize(m + 1, 6) = br
    
35.                     Erase br
    
36.                     wb.Save: GoTo t
    
37.                 End With
    
38.             End If
    
39.         Next
    
40.         MsgBox "" & WbName(w) & "未打开！"
    
41. t:      Next
    
42.     ThisWorkbook.Activate
    
43.     Application.ScreenUpdating = True
    
44. MsgBox "运行时间：" & Timer - sj & " 秒"
    
45. End Sub

复制代码

ykcbf1100

5年以前的问题现在还没解决？

玉阳山人

ynzsvt 发表于 2024-7-10 06:13

老师：看看是怎么回事？

玉阳山人

ynzsvt 发表于 2024-7-10 06:13

玉阳山人

ynzsvt 发表于 2024-7-10 06:13

yjh_27

在当前工作簿的路径下，没有找到要打开的文件

玉阳山人

yjh_27 发表于 2024-7-10 13:18
在当前工作簿的路径下，没有找到要打开的文件

0.zip (1.5 MB, 下载次数: 1)

2024-7-10 14:32 上传

点击文件名下载附件

Sub 按J1更新分表()
sj = Timer
    Application.ScreenUpdating = False
    Dim WbName, wa, wb, ar, br, i&, j&, r&, s&, m&, n&, v&, w&, x&, y&
    Set wa = ThisWorkbook:  s = [h2]: ar = Range("e5:j" & s)
    WbName = Array("0 三同.xlsm", "1 组三.xlsm", "2 组六.xlsm")
    If Cells(1, "J") >= 0 And Cells(1, "J") < 3 Then
        x = Cells(1, "J"): y = x
        ElseIf Cells(1, "J") = 3 Then x = 0: y = Cells(1, "J") - 1
        Else: MsgBox "J1输入有误！": Exit Sub
    End If
    For w = x To y
    ThisWorkbook.Activate
    If Cells(1, "J") = 3 Then Workbooks.Open (ThisWorkbook.Path & "\" & WbName(w))
        For Each wb In Workbooks
            ReDim br(1 To UBound(ar), 1 To 6)
            If wb.Name = WbName(w) Then
                wb.Activate: Sheets("总表").Activate
                With Sheets("总表")
                    v = .[i1]: n = .[h1]: m = 0
                    For i = 1 To UBound(ar)
                        If ar(i, 6) = v Then
                            m = m + 1
                            r = Application.Match(v, wa.Sheets("总表").Range("j5:j" & s), 0)
                            For j = 1 To 5: br(m, j) = ar(i, j): Next
                        End If
                    Next
                    For i = 1 To m
                        If i = 1 Then br(i, 6) = r Else br(i, 6) = br(i, 1) - br(i - 1, 1)
                    Next
                    br(m + 1, 6) = .[c1] - br(m, 1)
                    Range(.Cells(5, "e"), .Cells(n, "j")).ClearContents
                    .Cells(5, "e").Resize(m + 1, 6) = br
                    Erase br
                    wb.Save: GoTo t
                End With
            End If
        Next
        MsgBox "" & WbName(w) & "未打开！"
t:      Next
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
MsgBox "运行时间：" & Timer - sj & " 秒"
End Sub

在上面合适的地方，添加复制粘贴到目标工作簿《0 三同》，《1 组三》，《2 组六》E:I列的符合条件的所有数据，必须保留源工作表《00 总表》对应列E:I列原有数字格式的代码。

老师：我的想法不知对不对？--就是在需要复制粘贴的目标工作簿《0 三同》，《1 组三》，《2 组六》里，添加一句
Range("e5").Resize(m + 1, 6).NumberFormat = "@"
即可。可试了几处都不行。您看怎样解决为好？

玉阳山人

经过反复测试，添加下面红色代码后，可以实现我的想法。谢谢老师们

Sub 按J1更新分表()
    startTime = Timer
    Application.ScreenUpdating = False
    Dim WbName, wa, wb, ar, br, i&, j&, r&, s&, m&, n&, v&, w&, x&, y&
    Set wa = thisWorkbook: s = [h2]: ar = Range("e5:j" & s)
    WbName = Array("0 三同.xlsm", "1 组三.xlsm", "2 组六.xlsm")
    If Cells(1, "J") >= 0 And Cells(1, "J") < 3 Then
        x = Cells(1, "J"): y = x
    ElseIf Cells(1, "J") = 3 Then x = 0: y = Cells(1, "J") - 1
    Else: MsgBox "J1 输入有误！": Exit Sub
    End If
    For w = x To y
        thisWorkbook.Activate
        If Cells(1, "J") = 3 Then Workbooks.Open (thisWorkbook.Path & "\" & WbName(w))
            For Each wb In Workbooks
                ReDim br(1 To UBound(ar), 1 To 6)
                If wb.Name = WbName(w) Then
                    wb.Activate: Sheets("总表").Activate
                    With Sheets("总表")
                        v = .[i1]: n = .[h1]: m = 0
                        For i = 1 To UBound(ar)
                            If ar(i, 6) = v Then
                                m = m + 1
                                r = Application.Match(v, wa.Sheets("总表").Range("j5:j" & s), 0)
                                For j = 1 To 5: br(m, j) = ar(i, j): Next
                            End If
                        Next
                        For i = 1 To m
                            If i = 1 Then br(i, 6) = r Else br(i, 6) = br(i, 1) - br(i - 1, 1)
                        Next
                        br(m + 1, 6) = .[c1] - br(m, 1)
                        Range(.Cells(5, "e"), .Cells(n, "j")).ClearContents
                       .Cells(5, "e").Resize(m + 1, 6).NumberFormat = "@"
                       .Cells(5, "e").Resize(m + 1, 6) = br
                        Erase br
                        wb.Save: GoTo t
                    End With
                End If
            Next
            MsgBox "" & WbName(w) & " 未打开！"
t:         Next
    thisWorkbook.Activate
    Application.ScreenUpdating = True
    MsgBox "运行时间：" & Timer - startTime & " 秒"
End Sub