数据量稍微一大就内存不够用 大神来助

LMY123

ado多薄首表合并，f1等于合并工作薄名称

hexaking

朱荣兴 发表于 2018-10-10 16:18
意思基本看懂了，其实你是思路没有考虑好，才会导致那么长的代码，频繁的打开工作簿文件，最终才会导致运行 ...

多谢 我试试看

hexaking

LMY123 发表于 2018-10-10 16:23
ado多薄首表合并，f1等于合并工作薄名称

不懂 我尝试学下 谢谢

wuxianyu86

Sub 收集数据()
Dim datawb As Object
[A1:D1] = Array("日期", "项目", "测值", "源数据文件名")
[h1] = ThisWorkbook.Path & "\源数据" '设置源数据文件夹
For i = 2 To [F65535].End(xlUp).Row '从F列获取工作薄名称
Path = [h1] & "\" & Format(Cells(i, "f"), "yyyy-m-d") & ".xlsx" '设置源数据文件路径
Set datawb = GetObject(Path) '获取工作薄workbook对象
mylastrow = Sheets("收集数据").Range("A65535").End(xlUp).Row '当前表A列最后一行
datalastrow = datawb.Sheets(1).Range("a65535").End(xlUp).Row '源数据表数据行数
n = mylastrow + 1 '写入当前表的行数标识
For j = 2 To datalastrow
    Cells(n, "A") = datawb.Sheets(1).Cells(1, 1) '日期
    Cells(n, "B") = datawb.Sheets(1).Cells(j, 1) '测量项目
    Cells(n, "C") = datawb.Sheets(1).Cells(j, 2) '测值
    Cells(n, "D") = datawb.Name '源数据工作薄名称
n = n + 1 '写入行+1准备写入下一行
Next j '下一条源数据
datawb.Close '关闭源数据工作薄
Next i '下一个源数据工作薄
End Sub

wuxianyu86

先把所有数据都收集到一起让后再分析，最近我也是在学习VBA,代码写的不咋滴，只写了个收集数据的.希望对你有帮助；直接取的数据，估计速度不行；

wuxianyu86

传个附件怎么莫名的多了个 复件3 库存.rar 还不能删除

LMY123

hexaking 发表于 2018-10-10 18:10
不懂 我尝试学下 谢谢

Sub ADO_多薄首表_合并_无标题行()
    Range("A2:Z1048576") = ""
    Set conn = CreateObject("adodb.connection")
    Path = ThisWorkbook.Path
    n = UBound(Split(Path, "\"))
    sPath = Replace(Path, Split(Path, "\")(n), "源数据/")
    Fn = Dir(sPath & "*.xls?")
    Set Rst = VBA.CreateObject("ADODB.Recordset")
    Application.ScreenUpdating = False
    Do While Len(Fn)
        If InStr(Fn, "0030") = 0 And InStr(Fn, "test") = 0 Then
            sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;extended Properties='excel 12.0;HDR=no';data source=" & sPath & Fn
            SQL = "Select F2 from [A:B] Where f1='" & Split(ThisWorkbook.Name, ".")(0) & "'"
            Rst.Open SQL, sConnect, 3, 1
            If Not (Rst.BOF And Rst.EOF) Then
                Set Rng = Cells(Rows.Count, 2).End(3).Offset(1)
                Rng.CopyFromRecordset Rst
                Rng.Offset(, -1).Resize(Rst.RecordCount) = "'" & Split(Fn, ".")(0)
            End If
            Rst.Close
        End If
        Fn = Dir()
    Loop
    Application.ScreenUpdating = True
    Set Rst = Nothing
    Set Rng = Nothing
End Sub
Sub 批量复制文件() ''代码在另一工作薄中使用
    Path = ThisWorkbook.Path
    For h = 2 To 100
        FileCopy Path & "\A1.xlsm", Path & "\" & "A" & h & ".xlsm"
    Next h
End Sub

hexaking

wuxianyu86 发表于 2018-10-10 22:51
Sub 收集数据()
Dim datawb As Object
[A1:D1] = Array("日期", "项目", "测值", "源数据文件名")

我试试看 多谢大佬

hexaking

LMY123 发表于 2018-10-11 09:42
Sub ADO_多薄首表_合并_无标题行()
    Range("A2:Z1048576") = ""
    Set conn = CreateObject("adod ...

谢谢指教 我研究下