批量求各工作薄列数据差数的问题

杨小妹

附件 批量求各工作薄列数据差数.rar (533.17 KB, 下载次数: 14)

2024-2-19 10:55 上传

点击文件名下载附件

谢谢老师！

明天会更好zj

哈哈

fzxba

批量求各工作薄列数据差数.zip (20.55 KB, 下载次数: 13)

2024-2-19 11:34 上传

点击文件名下载附件

洋务德雷

。。。。。。。。。。

洋务德雷

。。。。。。。。

ykcbf1100

如果我没猜错的话，数据应该写在xlsb文件中。

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.19
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     a = [{13,14,16}]  '//M、N、P列列号
   
8.     b = [{21,22,23}]  '//U、V、W列列号
   
9.     On Error Resume Next
   
10.     For Each f In Fso.GetFolder(p).Files
    
11.         If f.Name Like "*.xlsb" Then
    
12.             fn = Fso.GetBaseName(f)
    
13.             Set wb = Workbooks.Open(f, 0)
    
14.             With wb.Sheets("Sheet2")
    
15.                 r = .Cells(Rows.Count, 1).End(3).Row
    
16.                 .Range("u1:w" & r) = ""
    
17.                 arr = .[a1].Resize(r + 1, 23)
    
18.                 For i = 1 To UBound(arr) Step 3
    
19.                     For x = 1 To UBound(b)
    
20.                         arr(i + 1, b(x)) = arr(i, a(x)) - arr(i + 1, a(x))
    
21.                     Next
    
22.                 Next
    
23.                 .[a1].Resize(r + 1, 23) = arr
    
24.             End With
    
25.             wb.Close 1
    
26.         End If
    
27.     Next f
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    
31. 
    

复制代码

杨小妹

ykcbf1100 发表于 2024-2-19 11:38
如果我没猜错的话，数据应该写在xlsb文件中。

附件供参考。。。

谢谢老师指点。数据应该返回到各工作薄相应列中。

limonet

关键字：dir

limonet

Sub limonet()
    Application.ScreenUpdating = False
    Dim Arr As Variant, i%, Brr As Variant, Path$, FileName$
    Path = ThisWorkbook.Path & "\"
    FileName = Dir(Path & "*.xlsb")
    Do While FileName <> ""
        Workbooks.Open Path & FileName
        i = Range("M1048576").End(xlUp).Row
        Arr = Range("M1:P" & i).Value
        ReDim Brr(1 To i, 1 To 3)
        For i = 2 To i Step 3
            Brr(i, 1) = Arr(i - 1, 1) - Arr(i, 1)
            Brr(i, 2) = Arr(i - 1, 2) - Arr(i, 2)
            Brr(i, 3) = Arr(i - 1, 4) - Arr(i, 4)
        Next i
        Range("U1").Resize(i - 3, 3) = Brr
        ActiveWorkbook.Close True
        FileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub