批量抽取行数据的问题

谢玉红

附件 批量抽取行数据.rar (534.51 KB, 下载次数: 26)

2024-6-16 21:57 上传

点击文件名下载附件

谢谢老师！

谢玉红

求老师帮忙。谢谢了。

liulang0808

楼主看下附件内容，是否与描述的一致？
具体打开文件赋值内容，论坛案例很多，可以参考下
https://club.excelhome.net/threa ... tml?_dsign=73cffde5遍历文件案例，可以参考

ykcbf1100

附件供参考。。。

ykcbf1100

多工作簿批量数据复制，并另存新文件中

1. Sub ykcbf()  '//2024.6.17
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     With sh
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         zrr = .[a1].Resize(r, 1)
   
9.     End With
   
10.     p = ThisWorkbook.Path & ""
    
11.     p1 = p & "另存文件夹"
    
12.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
13.     For Each f In fso.GetFolder(p).Files
    
14.         If LCase$(f.Name) Like "*.xls*" Then
    
15.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
16.                 fn = fso.GetBaseName(f)
    
17.                 Set wb = Workbooks.Open(f, 0)
    
18.                 With wb.Sheets("Sheet1")
    
19.                     r = .Cells(Rows.Count, 1).End(3).Row
    
20.                     c = .UsedRange.Columns.Count
    
21.                     arr = .[a1].Resize(r, c)
    
22.                     wb.Close False
    
23.                 End With
    
24.                 m = 0
    
25.                 ReDim brr(1 To r, 1 To c)
    
26.                 For i = 1 To UBound(zrr)
    
27.                     m = m + 1
    
28.                     For j = 1 To UBound(arr, 2)
    
29.                         brr(m, j) = arr(zrr(i, 1), j)
    
30.                     Next
    
31.                 Next
    
32.                 Application.SheetsInNewWorkbook = 1
    
33.                 Set wb = Workbooks.Add
    
34.                 wb.Sheets(1).[a1].Resize(m, c) = brr
    
35.                 wb.SaveAs p1 & "工作簿" & fn, xlExcel12
    
36.                 wb.Close
    
37.             End If
    
38.         End If
    
39.     Next f
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码

谢玉红

ykcbf1100 发表于 2024-6-17 08:26
多工作簿批量数据复制，并另存新文件中

老师你好，非常感谢你的帮助。试了一下，工作薄在80万行时，运行正常。工作薄超过100万行时，提示出错。提示：运行错误 7，内存溢出。代码指向第21行。 arr = .[a1].Resize(r, c)

ykcbf1100

谢玉红 发表于 2024-6-17 08:58
老师你好，非常感谢你的帮助。试了一下，工作薄在80万行时，运行正常。工作薄超过100万行时，提示出错。 ...

数组大小可能有极限。
数据量大，可能用SQL更好。

LIUZHU

谢玉红 发表于 2024-6-17 08:58
老师你好，非常感谢你的帮助。试了一下，工作薄在80万行时，运行正常。工作薄超过100万行时，提示出错。 ...

几十万行的数据，数组都不一定装的下，需要循环读取了

魂断蓝桥

用数据库吧，我用access试了一下，比较卡，用sqlite还可以，你可以试一试

模拟表格最大104万行



我这里的电脑建立数据库大概需要5分钟，查询的话就这些数据不超过3秒

数据库大概80MB 左右






Option Explicit
Dim CNN As New cConnection
Dim RS As New cRecordset
Dim SQL As String
Sub a()
    Dim tim, TS
    tim = Timer
    TS = MsgBox("重新建立数据库", vbYesNo)
    If TS = vbYes Then
        Call 建立数据库
    Else
        Call 查询数据库
    End If
    Set CNN = Nothing
    Set RS = Nothing
    If Dir(ThisWorkbook.Path & "\a.db") = "" Then
        MsgBox "没有建立数据库"
        Exit Sub
    End If
    MsgBox Format(Timer - tim, "0.00")
End Sub
Sub 建立数据库()
    Dim r As Range, I&, j&, S, BT, myfile, brr(), m&, s1$
    If Dir(ThisWorkbook.Path & "\a.db") <> "" Then Kill ThisWorkbook.Path & "\a.db"
    Application.ScreenUpdating = False
    CNN.CreateNewDB ThisWorkbook.Path & "\a.db"
    myfile = Dir(ThisWorkbook.Path & "\*.xlsb")
    CNN.BeginTrans
    Do While myfile <> ""
        If myfile <> ThisWorkbook.Name Then
            BT = ""
            S = Replace(myfile, ".xlsb", "")
            m = m + 1
            ReDim Preserve brr(1 To m)
            brr(m) = "表_" & S
            Workbooks.Open ThisWorkbook.Path & "\" & myfile
            Set r = [a1].CurrentRegion
            For j = 1 To r.Columns.Count
                BT = BT & "F" & j & ","
            Next
            BT = Left(BT, Len(BT) - 1)
            SQL = "CREATE TABLE 表_" & S & "(ID INTEGER PRIMARY KEY AUTOINCREMENT," & BT & ")"
            CNN.Execute SQL
            For I = 1 To r.Rows.Count
                s1 = ""
                For j = 1 To r.Columns.Count
                    s1 = s1 & r.Cells(I, j) & ","
                Next
                s1 = Left(s1, Len(s1) - 1)
                SQL = "INSERT INTO 表_" & S & "( " & BT & ") Values(" & s1 & ")"
                CNN.Execute SQL
            Next
            Workbooks(myfile).Close , 0
        End If
        myfile = Dir
    Loop
    CNN.CommitTrans
    Application.ScreenUpdating = False
End Sub
Sub 查询数据库()
    Dim ARR, I&, S$, brr
    Dim tow As Workbook
    Application.ScreenUpdating = False
    On Error Resume Next
    Kill ThisWorkbook.Path & "\输出\*.*"
    RmDir ThisWorkbook.Path & "\输出"
    On Error GoTo 0
    ARR = [a1].CurrentRegion
    For I = 1 To UBound(ARR)
        S = S & ARR(I, 1) & ","
    Next
    S = "(" & Left(S, Len(S) - 1) & ")"
    CNN.OpenDB ThisWorkbook.Path & "\a.db"
    SQL = "SELECT name FROM sqlite_master WHERE type='table'  AND NAME LIKE '表%'"
    RS.OpenRecordset SQL, CNN
    brr = RS.GetRows
    MkDir ThisWorkbook.Path & "\输出"
    For I = 0 To UBound(brr, 2)
        SQL = "select * from " & brr(0, I) & " where id in" & S
        RS.OpenRecordset SQL, CNN
        Set tow = Workbooks.Add
        tow.Sheets(1).[a1].CopyFromRecordset RS.GetADORsFromContent
        tow.Sheets(1).Range("a:a").Delete
        tow.SaveAs ThisWorkbook.Path & "\输出\" & brr(0, I) & ".xlsb", FileFormat:=xlExcel12
        tow.Close 1
    Next
    Application.ScreenUpdating = True
End Sub