批量提取行数据的问题

杨小妹

附件 批量提取行数据附件.rar (740.25 KB, 下载次数: 17)

2024-2-22 16:10 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

代码更新。。。

1. Sub ykcbf()  '//2024.2.22
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     p = ThisWorkbook.Path & ""
   
8.     '    On Error Resume Next
   
9.     For Each f In Fso.GetFolder(p).Files
   
10.         If f.Name Like "*.xlsb" Then
    
11.             fn = Fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             For Each sht In wb.Worksheets
    
14.                 If sht.Name = "结果" Then
    
15.                     sht.Delete
    
16.                     Exit For
    
17.                 End If
    
18.             Next
    
19.             With wb.Sheets("Sheet2")
    
20.                 arr = .UsedRange
    
21.                 m = 0
    
22.                 ReDim brr(1 To UBound(arr), 1 To 24)
    
23.                 For i = 1 To UBound(arr) Step 3
    
24.                     m = m + 1
    
25.                     s1 = arr(i, 14)
    
26.                     s2 = i + 1
    
27.                     For j = 1 To UBound(arr, 2)
    
28.                         brr(m, j) = arr(i + 1, j)
    
29.                     Next
    
30.                     brr(m, 15) = s1
    
31.                     brr(m, 24) = s2
    
32.                 Next
    
33.                 Set sht = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
    
34.                 sht.Name = "结果"
    
35.                 sht.[a1].Resize(m, 24) = brr
    
36.             End With
    
37.             wb.Close 1
    
38.         End If
    
39.     Next f
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
42. End Sub
    

复制代码

杨小妹

ykcbf1100 发表于 2024-2-22 16:46
附件供参考。。。

谢谢老师帮助。试了一下，提示下标越界。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, r&, strFileName$, strPath$
   
    Application.ScreenUpdating = False
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsb")
    Do Until strFileName = ""
        
        With Workbooks.Open(strPath & strFileName)
            .Worksheets("Sheet2").Activate
            ar = .ActiveSheet.UsedRange.Value
            With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
                ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) + 1)
                r = 0
                For i = 2 To UBound(ar) Step 3
                    r = r + 1
                    ar(i, 14) = ar(i - 1, 13)
                    For j = 1 To UBound(ar, 2)
                        br(r, j) = ar(i, j)
                    Next j
                    br(r, UBound(br, 2)) = i
                Next i
                .[A1].Resize(r, UBound(br, 2)) = br
            End With
            .Close True
        End With
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

ykcbf1100

杨小妹 发表于 2024-2-22 17:15
谢谢老师帮助。试了一下，提示下标越界。

改好了。。。

LIUZHU

JSA参与一波

LIUZHU

WPS测试运行