excel cannot complete this task with available resources

**Minglism** · 10-02-2008, 10:14 PM

Hi folks,

I encountered a memory problem when I ran my codes. Basically I used the codes to compare two similar entries in two excel files and then saved each comparison result in a new excel file.

The problem is that when the entry number increases to 7000 and above, a error message pops out saying: excel cannot complete this task with available resources. I checked the memory of the computer. There is still half of the memory unused.

I think it may reach the limit of memory usage for excel 2007 (2Gb). Do you guys have any idea how to release memory using VBA codes? Or any other idea how to solve the problem?

By the way I don't think it is the problem with copying and pasting since I didn't use many. I suspect that it is because I created too many workbooks (over 7000).

My system info:
Excel 2007 & Windows XP Home Edition SP2
Intel Core 2 Quad CPU Q6600 @ 2.4GHz
3.23GB of RAM

Here is the code:

[vba]
Dim AK_14 As Workbook, AK_15 As Workbook
Dim Pre_candi As String, Char_candi As String, FileName As String, pre_Candii As String
Dim i As Long, j As Long, row_n14 As Long, row_n15 As Long, col_n14 As Integer, col_n15 As Integer, row_res As Long, rows_n15 As Long
Dim m As Integer, n As Integer, Com_Ions As Integer, Com_YBs As Integer, Cols_N14 As Integer, Cols_N15 As Integer
Dim Int_N14 As Single, Int_N15 As Single, DotPro As Single

Sub Spectra_Verfication()

Application.ScreenUpdating = False
'Application.ScreenUpdating = True
Set AK_14 = Workbooks.Open(ThisWorkbook.Path & "\" & "extracted results (N14).xlsx")
Set AK_15 = Workbooks.Open(ThisWorkbook.Path & "\" & "extracted results (N15).xlsx")
'******************************** Sort the two results files according to charge and sequence *****************************
AK_14.Sheets(1).Activate '*
If Cells(3, 1) = "" Then
For i = 3 To [c1048576].End(xlUp).Row Step 3
Cells(i, 1) = Cells(i - 1, 1): Cells(i + 1, 1) = Cells(i - 1, 1)
Next
End If
i = [d1048576].End(xlUp).Row
j = ActiveSheet.UsedRange.Columns.Count
Cells.Select
With ActiveWorkbook.Worksheets("Sheet1").Sort '*
.SortFields.Clear
.SortFields.Add Key:=Range("d1"), _
SortOn:=SortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal

.SetRange Range(Cells(2, 1), Cells(i, j)) '*
.Header = xlNo '*
.MatchCase = False '*
.Orientation = xlTopToBottom '*
.SortMethod = xlPinYin '*
.Apply '*
End With '*

With ActiveWorkbook.Worksheets("Sheet1").Sort '*
.SortFields.Clear
.SortFields.Add Key:=Range("a1"), _
SortOn:=SortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range(Cells(2, 1), Cells(i, j)) '*
.Header = xlNo '*
.MatchCase = False '*
.Orientation = xlTopToBottom '*
.SortMethod = xlPinYin '*
.Apply '*
End With '*
'*
AK_15.Sheets(1).Activate
If Cells(3, 1) = "" Then
For i = 3 To [c1048576].End(xlUp).Row Step 3
Cells(i, 1) = Cells(i - 1, 1): Cells(i + 1, 1) = Cells(i - 1, 1)
Next
End If '*
i = [d1048576].End(xlUp).Row
j = ActiveSheet.UsedRange.Columns.Count
Cells.Select
With ActiveWorkbook.Worksheets("Sheet1").Sort '*
.SortFields.Clear
.SortFields.Add Key:=Range("d1"), _
SortOn:=SortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal

.SetRange Range(Cells(2, 1), Cells(i, j)) '*
.Header = xlNo '*
.MatchCase = False '*
.Orientation = xlTopToBottom '*
.SortMethod = xlPinYin '*
.Apply '*
End With '*

With ActiveWorkbook.Worksheets("Sheet1").Sort '*
.SortFields.Clear
.SortFields.Add Key:=Range("a1"), _
SortOn:=SortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range(Cells(2, 1), Cells(i, j)) '*
.Header = xlNo '*
.MatchCase = False '*
.Orientation = xlTopToBottom '*
.SortMethod = xlPinYin '*
.Apply '*
End With
'************************************************************************** *************************************************
AK_14.Sheets(1).Activate '*
row_n15 = 2: rows_n15 = row_n15 '*
For i = 2 To [a1048576].End(xlUp).Row Step 3 '*
AK_14.Sheets(1).Activate '*
Pre_candi = Cells(i, 1) & Cells(i, 11): pre_Candii = Pre_candi

pre_Candii = Cells(i + 3, 1) & Cells(i + 3, 11)
'*
Char_candi = Cells(i, 4) '*
row_n14 = i '*
col_n14 = Cells(i, 10000).End(xlToLeft).Column '*
Range(Cells(i, 1), Cells(i + 2, col_n14)).EntireRow.Select '*
Selection.Copy '*
ThisWorkbook.Sheets(1).Activate '*
Range(Cells(2, 2), Cells(col_n14 + 1, 4)).Select '*
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True '*
AK_15.Sheets(1).Activate '*
For j = row_n15 To [a1048576].End(xlUp).Row Step 3 '*
If Pre_candi = (Cells(j, 1) & Cells(j, 11)) And Char_candi = Cells(j, 4) Then '*
row_n15 = j
If pre_Candii = Pre_candi Then '***************** judge where to start comparison for next entry **********
row_n15 = rows_n15
Else
rows_n15 = row_n15
End If
'*
col_n15 = Cells(j, 10000).End(xlToLeft).Column '*
Range(Cells(j, 1), Cells(j + 2, col_n15)).EntireRow.Select '*
Selection.Copy '*
ThisWorkbook.Sheets(1).Activate '*
Range(Cells(2, 6), Cells(col_n15 + 1, 8)).Select '*
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True '*
'**************************************** spectra verification algorithm ***************************************************
Frag_Cpr '*
Result_Output '*
'**************************************** judge if cycle goes on ***********************************************************
AK_15.Sheets(1).Activate '*
If Pre_candi <> Cells(j + 3, 1) Or Char_candi <> Cells(j + 3, 4) Or j = [a1048576].End(xlUp).Row - 3 Then '*
'*
ThisWorkbook.Sheets(1).Activate '*
Range(Cells(2, 2), Cells(1000, 14)).Select '*
Selection.Delete Shift:=xlUp '*
Exit For
End If '*
'************************************************************************** *************************************************

End If
Next j
'*************************************** Output if no N15 counterpart ******************************************************
ThisWorkbook.Sheets(1).Activate
If Cells(2, 1000).End(xlToLeft).Column = 4 Then
Empty_Output
End If
Next i
'*************************************** Save the overall result and exit***************************************************

ThisWorkbook.Sheets(2).Activate
Cells.Select
Selection.Copy
Workbooks.Add
ActiveWorkbook.Sheets(1).Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & "N14_CPw_N15_final_result.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close False
ThisWorkbook.Sheets(2).[2:1048576].Clear

Application.ScreenUpdating = True
MsgBox "Mredd Foxy Xu Rocks!!!"
ThisWorkbook.Close False
End Sub
Sub Frag_Cpr()
ThisWorkbook.Sheets(1).Activate
Int_N14 = 0: Int_N15 = 0: Com_Ions = 0: Com_YBs = 0: DotPro = 0: Int_N14 = 0: Int_N15 = 0
'********************************************** alignment of common ions (only YB) **********************************************
For m = 14 To col_n14 + 1
For n = 14 To col_n15 + 1
If Cells(m, 2) = Cells(n, 6) Then
Com_Ions = Com_Ions + 1
Cells(m, 2).Interior.Color = 255: Cells(n, 6).Interior.Color = 255
If Mid(Cells(m, 2), 1, 1) = "y" Or Mid(Cells(m, 2), 1, 1) = "b" Then
If Mid(Cells(m, 2), 3, 1) <> "+" Then
Com_YBs = Com_YBs + 1: Cells(m, 2).Interior.Color = 65535: Cells(n, 6).Interior.Color = 65535
Int_N14 = Int_N14 + (Cells(m, 4) ^ 2): Int_N15 = Int_N15 + (Cells(n, 8) ^ 2)
DotPro = (Cells(m, 4) ^ 1) * (Cells(n, 8) ^ 1) + DotPro
End If
End If
Exit For
End If
Next
Next
If Int_N14 * Int_N15 <> 0 Then
DotPro = DotPro / ((Int_N14 * Int_N15) ^ 0.5)
Else
DotPro = 0
End If
[j2] = col_n14 - 12: [k2] = col_n15 - 12: [l2] = Com_Ions: [m2] = Com_YBs: [n2] = DotPro
End Sub
Sub Result_Output()
ThisWorkbook.Sheets(2).Activate
row_res = [a1048576].End(xlUp).Row + 1
Cells(row_res, 1) = ThisWorkbook.Sheets(1).Cells(2, 2)
Cells(row_res, 2) = ThisWorkbook.Sheets(1).Cells(3, 2)
Cells(row_res, 3) = ThisWorkbook.Sheets(1).Cells(10, 2)
Cells(row_res, 4) = ThisWorkbook.Sheets(1).Cells(10, 6)
Cells(row_res, 5) = ThisWorkbook.Sheets(1).Cells(4, 2)
Cells(row_res, 6) = ThisWorkbook.Sheets(1).Cells(5, 2)
Cells(row_res, 7) = ThisWorkbook.Sheets(1).Cells(6, 2)
Cells(row_res, 8) = ThisWorkbook.Sheets(1).Cells(6, 6)
Cells(row_res, 9) = ThisWorkbook.Sheets(1).Cells(7, 2)
Cells(row_res, 10) = ThisWorkbook.Sheets(1).Cells(7, 6)
FileName = Cells(row_res, 9) & "_N14_" & i & "_CW_" & Cells(row_res, 10) & "_N15_" & j
Cells(row_res, 11) = ThisWorkbook.Sheets(1).Cells(9, 2)
Cells(row_res, 12) = ThisWorkbook.Sheets(1).Cells(13, 2)
Cells(row_res, 13) = ThisWorkbook.Sheets(1).Cells(13, 6)
Cells(row_res, 14) = ThisWorkbook.Sheets(1).Cells(11, 2)
Cells(row_res, 15) = ThisWorkbook.Sheets(1).Cells(12, 2)
Cells(row_res, 16) = col_n14 - 12
Cells(row_res, 17) = col_n15 - 12
Cells(row_res, 18) = Com_Ions
Cells(row_res, 19) = Com_YBs
Cells(row_res, 20) = DotPro
Cells(row_res, 21) = FileName
ActiveSheet.Hyperlinks.Add Anchor:=Cells(row_res, 21), Address:="xlsxs\" & FileName & ".xlsx", TextToDisplay:=FileName
ThisWorkbook.Sheets(1).Activate
Cells.Select
Selection.Copy
Workbooks.Add

ActiveWorkbook.Sheets(1).Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\xlsxs\" & FileName & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Spec_Cpr
ActiveWindow.Close True
ThisWorkbook.Sheets(1).Activate
Range(Cells(2, 2), Cells(1000, 8)).Select
Selection.Interior.Pattern = xlNone
Range(Cells(2, 5), Cells(1000, 14)).Select
Selection.Delete Shift:=xlUp

End Sub
Sub Empty_Output()
ThisWorkbook.Sheets(2).Activate
row_res = [a1048576].End(xlUp).Row + 1
Cells(row_res, 1) = ThisWorkbook.Sheets(1).Cells(2, 2)
Cells(row_res, 2) = ThisWorkbook.Sheets(1).Cells(3, 2)
Cells(row_res, 3) = ThisWorkbook.Sheets(1).Cells(10, 2)
Cells(row_res, 4) = "N/A"
Cells(row_res, 5) = ThisWorkbook.Sheets(1).Cells(4, 2)
Cells(row_res, 6) = ThisWorkbook.Sheets(1).Cells(5, 2)
Cells(row_res, 7) = ThisWorkbook.Sheets(1).Cells(6, 2)
Cells(row_res, 8) = "N/A"
Cells(row_res, 9) = ThisWorkbook.Sheets(1).Cells(7, 2)
Cells(row_res, 10) = "N/A"
'FileName = Cells(row_res, 9) & "_N14_" & i & "Alone"
Cells(row_res, 11) = ThisWorkbook.Sheets(1).Cells(9, 2)
Cells(row_res, 12) = ThisWorkbook.Sheets(1).Cells(13, 2)
Cells(row_res, 13) = "N/A"
Cells(row_res, 14) = ThisWorkbook.Sheets(1).Cells(11, 2)
Cells(row_res, 15) = ThisWorkbook.Sheets(1).Cells(12, 2)
Cells(row_res, 16) = col_n14 - 12
Cells(row_res, 17) = "N/A"
Cells(row_res, 18) = "N/A"
Cells(row_res, 19) = "N/A"
Cells(row_res, 20) = "N/A"
Cells(row_res, 21) = "N/A"
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(row_res, 21), Address:="xlsxs\" & FileName & ".xlsx", TextToDisplay:=FileName
ThisWorkbook.Sheets(1).Activate
'Cells.Select
'Selection.Copy
'Workbooks.Add
'ActiveWorkbook.Sheets(1).Cells(1, 1).Select
'Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\xlsxs\" & "_" & FileName & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'ActiveWindow.Close False
'ThisWorkbook.Sheets(1).Activate
Range(Cells(2, 2), Cells(1000, 8)).Select
Selection.Delete Shift:=xlUp

End Sub
Sub Spec_Cpr()
'
Cols_N14 = [d1048576].End(xlUp).Row
Cols_N15 = [h1048576].End(xlUp).Row
'******************************************* sort according to cell color ************************************
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range(Cells(14, 2), Cells(Cols_N14, 2)), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
255, 0)
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range(Cells(14, 2), Cells(Cols_N14, 2)), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(Cells(14, 2), Cells(Cols_N14, 4))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range(Cells(14, 6), Cells(Cols_N15, 6)), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, _
255, 0)
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add(Range(Cells(14, 6), Cells(Cols_N15, 6)), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range(Cells(14, 6), Cells(Cols_N15, 8))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'************************************** Display Spectra Comparison ************************************
Cells(2, Cols_N14 + 1).Select
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
.ChartType = xlColumnClustered
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""N14"""
.SeriesCollection(1).Values = Range(Cells(14, 4), Cells(13 + Com_Ions, 4)).Value
.SeriesCollection.NewSeries
.SeriesCollection(2).Name = "=""N15"""
.SeriesCollection(2).Values = Range(Cells(14, 8), Cells(13 + Com_Ions, 8)).Value
.SeriesCollection(2).XValues = Range(Cells(14, 2), Cells(13 + Com_Ions, 2)).Value
.ApplyLayout (1)
.ChartTitle.Select
.ChartTitle.Text = Cells(2, 2).Value
.SetElement (msoElementPrimaryValueAxisTitleRotated)
.Axes(xlValue, xlPrimary).AxisTitle.Text = "Intensity"
End With
Range(Cells(2, 3), Cells(13, 4)).Clear
Range(Cells(2, 7), Cells(13, 8)).Clear

End Sub

[/vba]

**Slyboots** · 10-03-2008, 07:58 AM

It may be that the Undo stack is filling up as the macro runs. You can clear it after each Add-Close operation, by adding a "do-nothing" line of code:

Sub ClearUndo()
Range("A1").Copy Range("A1")
End Sub
This clears out the stack. Hope this helps.

S

**Minglism** · 10-03-2008, 11:16 AM

It still builds up to the limit after processing 7000 files. Any other ideas?

**Slyboots** · 10-03-2008, 01:36 PM

Reading your code, I realized that you never clear the stack after copying, which may be causing a problem. After each Paste or PasteSpecial is complete, add the code:

Application.CutCopyMode = False

this may help.

S

Originally Posted by Minglism

It still builds up to the limit after processing 7000 files. Any other ideas?

**Minglism** · 10-03-2008, 02:19 PM

Sorry I didnt solve the problem. I found out that it was the problem with too many workbooks adding and closing. Do you have any idea how to solve that problem?

**Slyboots** · 10-03-2008, 04:19 PM

I don't have any more ideas about the memory issue. If it were my project, I would save each set of results as XML. In fact, you can set up results once, and save the file as XML to get the framework. Then, use that as a template to write out each text file.

Thread: excel cannot complete this task with available resources

Thread Tools

Display

excel cannot complete this task with available resources

Posting Permissions