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

hexaking

小白辛苦写的 开始效率真的高很多 后来数据量大了很容易就内存溢出
8G内存 换了64位Excel仍然不能解决 很是无奈
可能原因是循环多 内存不能及时释放吧

主要功能就从一堆工作簿中找到特定位置复制粘贴到另一个指定工作簿 重复的打开关闭文件

望大神相助 搜索了很多仍没找到合适的解决办法

hexaking

1. Sub autodb()
   
2. 
   
3. 
   
4.     Dim r As Integer
   
5.     Dim w As Integer
   
6.     Dim i As Integer
   
7.     Dim q As Integer
   
8.     Dim y As Workbook
   
9.     Dim b As Workbook
   
10.     Dim FD
    
11.     Application.ScreenUpdating = False
    
12.     Application.Calculation = xlCalculationManual
    
13.     FD = ThisWorkbook.Sheets("Sheet1").Range("K3")
    
14.     For w = 1 To ThisWorkbook.Sheets("Sheet1").Range("L3")
    
15.     For r = 1 To 45
    
16.     Set y = Workbooks.Open("D:\Program Files (x86)\Desktop\资料\F\test" & Format(FD, "yyyy-m-d") & ".xlsx") '引用值（不同日期需修改）
    
17.     Set b = Workbooks.Open("D:\Program Files (x86)\Desktop\FC表\F\C" & r & ".xls")
    
18.     i = Worksheets.Count
    
19.     For q = 1 To i
    
20.     If b.Worksheets(q).Range("E24") = "" Then
    
21.     b.Worksheets(q).Activate
    
22.     Exit For
    
23.     Else
    
24.     End If
    
25.     Next q
    
26.     If r < 23 Then
    
27.     If ActiveSheet.Range("A24") = "" Then
    
28.     y.Sheets("C ").Cells(5, 2).Copy
    
29.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
30.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("C ").Cells(10 + r, 3) * 1000 '本次测值（不同日期需修改）
    
31.     y.Close 0
    
32.     Else
    
33.     y.Sheets("C ").Cells(5, 2).Copy
    
34.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
35.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("C ").Cells(10 + r, 3) * 1000 '本次测值（不同日期需修改）
    
36.     y.Close 0
    
37.     End If
    
38.     Else
    
39.     If ActiveSheet.Range("A24") = "" Then
    
40.     y.Sheets("C ").Cells(5, 2).Copy
    
41.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
42.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("C ").Cells(35 + r, 3) * 1000 '本次测值（不同日期需修改）
    
43.     y.Close 0
    
44.     Else
    
45.     y.Sheets("C ").Cells(5, 2).Copy
    
46.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
47.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("C ").Cells(35 + r, 3) * 1000 '本次测值（不同日期需修改）
    
48.     y.Close 0
    
49.     End If
    
50.     End If
    
51.     b.Close 1
    
52.     Next r
    
53.     FD = DateAdd("d", ThisWorkbook.Sheets("Sheet1").Range("M3"), FD)
    
54.     Next w
    
55.     Application.ScreenUpdating = True
    
56.     Application.Calculation = xlCalculationAutomatic
    
57. End Sub
    
58. Sub autopc()
    
59. 
    
60. 
    
61.     Dim r As Integer
    
62.     Dim w As Integer
    
63.     Dim i As Integer
    
64.     Dim q As Integer
    
65.     Dim y As Workbook
    
66.     Dim b As Workbook
    
67.     Dim FD
    
68.     Application.ScreenUpdating = False
    
69.     Application.Calculation = xlCalculationManual
    
70.     FD = ThisWorkbook.Sheets("Sheet1").Range("K3")
    
71.     For w = 1 To ThisWorkbook.Sheets("Sheet1").Range("L3")
    
72.     For r = 1 To 30
    
73.     Set y = Workbooks.Open("D:\Program Files (x86)\Desktop\资料\F\test" & Format(FD, "yyyy-m-d") & ".xlsx") '引用值（不同日期需修改）
    
74.     Set b = Workbooks.Open("D:\Program Files (x86)\Desktop\FC表\F\PC" & r & ".xls")
    
75.     i = Worksheets.Count
    
76.     For q = 1 To i
    
77.     If b.Worksheets(q).Range("E24") = "" Then
    
78.     b.Worksheets(q).Activate
    
79.     Exit For
    
80.     Else
    
81.     End If
    
82.     Next q
    
83.     If r < 23 Then
    
84.     If ActiveSheet.Range("A24") = "" Then
    
85.     y.Sheets("PC").Cells(5, 2).Copy
    
86.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
87.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("PC").Cells(10 + r, 3) * 1000 '本次测值（不同日期需修改）
    
88.     y.Close 0
    
89.     Else
    
90.     y.Sheets("PC").Cells(5, 2).Copy
    
91.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
92.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("PC").Cells(10 + r, 3) * 1000 '本次测值（不同日期需修改）
    
93.     y.Close 0
    
94.     End If
    
95.     Else
    
96.     If ActiveSheet.Range("A24") = "" Then
    
97.     y.Sheets("PC").Cells(5, 2).Copy
    
98.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
    
99.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("PC").Cells(35 + r, 3) * 1000 '本次测值（不同日期需修改）
    
100.     y.Close 0
     
101.     Else
     
102.     y.Sheets("PC").Cells(5, 2).Copy
     
103.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
     
104.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("PC").Cells(35 + r, 3) * 1000 '本次测值（不同日期需修改）
     
105.     y.Close 0
     
106.     End If
     
107.     End If
     
108.     b.Close 1
     
109.     Next r
     
110.     FD = DateAdd("d", ThisWorkbook.Sheets("Sheet1").Range("M3"), FD)
     
111.     Next w
     
112.     Application.ScreenUpdating = True
     
113.     Application.Calculation = xlCalculationAutomatic
     
114. End Sub
     
115. Sub autops()
     
116. 
     
117. 
     
118.     Dim r As Integer
     
119.     Dim w As Integer
     
120.     Dim i As Integer
     
121.     Dim q As Integer
     
122.     Dim y As Workbook
     
123.     Dim b As Workbook
     
124.     Dim FD
     
125.     Application.ScreenUpdating = False
     
126.     Application.Calculation = xlCalculationManual
     
127.     FD = ThisWorkbook.Sheets("Sheet1").Range("K3")
     
128.     For w = 1 To ThisWorkbook.Sheets("Sheet1").Range("L3")
     
129.     For r = 1 To 30
     
130.     Set y = Workbooks.Open("D:\Program Files (x86)\Desktop\资料\F\test" & Format(FD, "yyyy-m-d") & ".xlsx") '引用值（不同日期需修改）
     
131.     Set b = Workbooks.Open("D:\Program Files (x86)\Desktop\FC表\F\SY" & r & ".xls")
     
132.     i = Worksheets.Count
     
133.     For q = 1 To i
     
134.     If b.Worksheets(q).Range("E24") = "" Then
     
135.     b.Worksheets(q).Activate
     
136.     Exit For
     
137.     Else
     
138.     End If
     
139.     Next q
     
140.     If r < 23 Then
     
141.     If ActiveSheet.Range("A24") = "" Then
     
142.     y.Sheets("PSY").Cells(5, 2).Copy
     
143.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
     
144.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("PSY").Cells(10 + r, 4) * 1000 '本次测值（不同日期需修改）
     
145.     y.Close 0
     
146.     Else
     
147.     y.Sheets("PSY").Cells(5, 2).Copy
     
148.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
     
149.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("PSY").Cells(10 + r, 4) * 1000 '本次测值（不同日期需修改）
     
150.     y.Close 0
     
151.     End If
     
152.     Else
     
153.     If ActiveSheet.Range("A24") = "" Then
     
154.     y.Sheets("PSY").Cells(5, 2).Copy
     
155.     ActiveSheet.Range("A25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
     
156.     ActiveSheet.Range("B25").End(xlUp).Offset(1, 0) = y.Sheets("PSY").Cells(35 + r, 4) * 1000 '本次测值（不同日期需修改）
     
157.     y.Close 0
     
158.     Else
     
159.     y.Sheets("PSY").Cells(5, 2).Copy
     
160.     ActiveSheet.Range("E25").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues '日期（不同日期需修改）
     
161.     ActiveSheet.Range("F25").End(xlUp).Offset(1, 0) = y.Sheets("PSY").Cells(35 + r, 4) * 1000 '本次测值（不同日期需修改）
     
162.     y.Close 0
     
163.     End If
     
164.     End If
     
165.     b.Close 1
     
166.     Next r
     
167.     FD = DateAdd("d", ThisWorkbook.Sheets("Sheet1").Range("M3"), FD)
     
168.     Next w
     
169.     ThisWorkbook.Sheets("Sheet1").Range("K3") = Format(FD, "yyyy-m-d")
     
170.     Application.ScreenUpdating = True
     
171.     Application.Calculation = xlCalculationAutomatic
     
172. End Sub
     

复制代码

wuxianyu86

哇你这好复杂，代码看的头晕，可以考虑一下用数组提高运行速度。

王欢_(旗兴）

考虑一下ADO，用SQL查询

hexaking

实现的功能很简单 可不知该如何简化。。。

hexaking

朱荣兴 发表于 2018-10-10 07:44
从未见过如此之长的代码，太多循环，效率肯定低

对呀 请教如何简化以提高效率

hexaking

朱荣兴 发表于 2018-10-10 12:27
同时修改代码还不如自己写代码但是又不明白你具体的需求

大致是这样的，同附件:源数据每天会产生一组数据，我的目的是把源数据的A1~A5的测值按照时间顺序分别堆积到"归档"中的对应工作簿中(主要功能就是复制粘贴)，例如A1.XLSX三天的整理结果如图，主要问题是数据量一大的话、、、可能从A1~A100个类别，且同时需要处理20天或者一个月的数据！