VBA Run-Time Error 1004 - vba

I am debugging a VBA macro which ends with the following error message:
"Run-time error '1004':
"could not be found. Check the spelling of the file name, and verify
that the file location is correct.
If you are trying to open the file from your list of most recently used files, make sure that the file has not been remnamed, moved, or deleted."
I checked that I was not using deleted/removed/renamed files and they were not coming from my Recent Files list.
The offending portion of the code which triggers the error message:
Workbooks.OpenText Filename:=vCPath _
, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1)), _
TrailingMinusNumbers:=True
Here is all of the code:
' Changes to program to make
' Exclude outliers in average
' Develop fake data to at glance recognize whether program works.
' Source http://www.cpearson.com/excel/optimize.htm
' Declare .Filters
Option Explicit
Sub DataProcessingExperiment7()
On Error GoTo ErrorHandler
' Declare as strings, as integers, as variants, decDecimals, as Office.FileDialog
Dim strPath, strFileN, strDirN, strRangeNOut, strRangeNIn, strFilename, strTLCorn, strBRCorn, strSelectedFile, strtemp_name As String
Dim vResMatrix(), vCPath, vFileN As Variant
Dim vRangeNOut, vRangeNIn, decInd6, decInd4, decInd5, decStep2, decMRow, decColIn, decInd3, decMcol As Double
Dim decMxRNo, decBgrSum, decRowIn, decInd, decM40eff, decStep, decColNo, decStartcol, decStartrow As Double
Dim decPlateNo, decMonoVal, decInd1, decEntryRow2, decEntryRow, decInd2, decBgrValP, decBgrRow As Double
Dim decBrgSum, decBgrVal, decRangeNIn, decRangeNOut, decTLCorn, decVolcorr, decBRCorn, decMEeff As Double
Dim decMediaVal, M40Eff, decMeanComp As Double
' MEeff = measure of efflux due to crudely purified HDL in scintillation
' Math operations are fastest with Integers / UIntegers: https://msdn.microsoft.com/en-us/library/ae55hdtk.aspx
' Start File Explorer to select file containing data
Dim lngCount As Long
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
Next lngCount
For Each strFilename In .SelectedItems
MsgBox strFilename
Next
End With
' Excel 2003 is a good filter choice: Excel Viewer, OpenOffice, + Excel versions can open these files
' If .Show = - 1 user picked at least one file
' The user pressed cancel.
' Assign strings to param locations from (1,2) to (7,2). This matches template
' Now using relative references to increase portability and NOT SELECTING the cells to increase macro speed, shorten code
With ActiveCell
.Offset(1, 2) = decPlateNo
.Offset(2, 2) = decStartrow
.Offset(3, 2) = decStartcol
.Offset(4, 2) = decColNo
.Offset(5, 2) = decStep
.Offset(6, 2) = strDirN
.Offset(7, 2) = strFileN
End With
' Measure of efflux of 2 plates of scint-40
M40Eff = 4.37
M40Eff = 2.4
' Select and copy data and range
Range("A1:O22").Select
Selection.Copy
MsgBox "start"
' Use the array
For decInd = 1 To decPlateNo / 2 - 1
decRowIn = 1 + decStep * 2 * decInd
decRangeNIn = "A" + CStr(decRowIn)
Range(decRangeNIn).Select
ActiveSheet.Paste
Next decInd 'Go to next indice
Application.CutCopyMode = False ' Have the data in both sheets
Workbooks.OpenText Filename:=vCPath _
, Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1)), _
TrailingMinusNumbers:=True
For decInd1 = 1 To decPlateNo 'Between these 2 columns
decTLCorn = "B" + CStr(decStartrow + (decInd1 - 1) * decStep)
decBRCorn = "M" + CStr(decStartrow + 7 + (decInd1 - 1) * decStep)
decRangeNOut = decTLCorn + ":" + decBRCorn
decRangeNIn = decTLCorn
Windows(vFileN).Activate
Range(vRangeNOut).Select
Selection.Copy
Windows(strtemp_name).Activate
Sheets("Data").Select
Range(vRangeNIn).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next decInd1
' Operation:=xlNone prevents calculations while pasting (less CPU intensive)
' Don't skip blanks, don't transpose
' Calculation of background and efflux for individual plates
For decInd1 = 1 To decPlateNo / 2
decStep2 = (decInd1 - 1) * decStep * 2
decBgrRow = decStartrow + 8 + decStep2
decBgrValP = Cells(decBgrRow, 2).Value 'Background plate value
For decInd2 = 0 To 7 'From column Ind2 to column 7 do multiplication
decEntryRow = decStartrow + decInd2 + decStep2
decEntryRow2 = decStartrow + decInd2 + decStep2 + 11
decMediaVal = Cells(decEntryRow, 13).Value
decMonoVal = Cells(decEntryRow2, 13).Value
Cells(decEntryRow, 15).Value = decMEeff * 100 * decVolcorr * (decMediaVal - decBgrValP) / (decM40eff * decMonoVal + decVolcorr * decMEeff * (decMediaVal - decBgrValP))
Next decInd2
Next decInd1
MsgBox "end"
' calculation of average background for all media plates
decBgrSum = 0
For decInd1 = 1 To decPlateNo / 2
decStep2 = (decInd1 - 1) * decStep * 2
For decInd2 = 0 To 7
decRowIn = decStartrow + decStep2 + decInd2
decBgrSum = decBgrSum + Cells(decRowIn, 2).Value
Next decInd2
Next decInd1
decBgrVal = decBgrSum / (4 * decPlateNo) 'The plates are split up into 4 (control (media) plates are 2 of them).
decBgrVal = Cells(2, 17).Value
' Rearanging data and transferring to Results sheet
decMxRNo = 8 * decColNo
ReDim vResMatrix(1 To decMxRNo, 1 To decPlateNo)
Sheets("Data").Select
For decInd1 = 1 To decPlateNo
decMcol = decInd1
For decInd2 = 1 To 8
decRowIn = (decInd1 - 1) * decStep + decStartrow + decInd2 - 1
For decInd3 = 1 To decColNo
decColIn = decStartcol + decInd3 - 1
decMRow = (decInd3 - 1) * 8 + decInd2
vResMatrix(decMRow, decMcol) = Cells(decRowIn, decColIn).Value
Next decInd3
Next decInd2
Next decInd1
Sheets("Results").Select
For decInd4 = 1 To decPlateNo
For decInd5 = 1 To decMxRNo
Cells(decInd5, decInd4).Value = vResMatrix(decInd5, decInd4) 'Put the values of the matrix in this range?
Next decInd5
Next decInd4
Sheets("Results QC").Select
' Select QC (quality control) calculation
Range("C81:C82").Select
Selection.Copy
For decInd = 1 To decPlateNo / 2 - 1
decColIn = 2 + 2 * decInd + 1
Cells(81, decColIn).Select
ActiveSheet.Paste 'Paste values of the active sheet (C81:C82 range)
Next decInd
For decInd4 = 1 To decPlateNo
decInd6 = decInd4 + 2
For decInd5 = 1 To decMxRNo 'Put these cell values in the matrix
Cells(decInd5, decInd6).Value = vResMatrix(decInd5, decInd4)
Next decInd5
Next decInd4
For decInd4 = 1 To decPlateNo
decInd6 = decInd4 + 2
decMeanComp = 0.6 * Cells(81, decInd6).Value
For decInd5 = 1 To decMxRNo
If Cells(decInd5, decInd6).Value < decMeanComp Then
Cells(decInd5, decInd6).Interior.Color = RGB(255, 0, 0)
' If the cell value is less than the average highlight them red as outliers. (More likely: from pipettes that didn't release)
ElseIf Cells(decInd5, decInd6).Value > decMeanComp Then
Cells(decInd5, decInd6).Interior.Color = RGB(7, 253, 56)
' If the cell value is greater than the average highlight them green as outliers. (Unlikely unless )
End If
Next decInd5
Next decInd4
MsgBox "4"
ErrorHandler:
MsgBox "Error Code" & Err.Number & vbNewLine & Err.Description, vbCritical, "Error Code" & Err.Number
End Sub
' Another function to continue arranging the data. Start by declaring all data types.
Sub Arrange_data()
On Error GoTo ErrorHandler
Dim strPath, strFileN, strDirN, strCPath, strRangeNOut, strRangeNIn, strTLCorn, strBRCorn As String
Dim decColIn4: decColIn4 = CDec(decColIn4)
Dim decInd5: decInd5 = CDec(decInd5)
Dim decInd6: decInd6 = CDec(decInd6)
Dim decPlateNo: decPlateNo = CDec(decPlateNo)
Dim decStartrow: decStartrow = CDec(decStartrow)
Dim decStartcol: decStartcol = CDec(decStartcol)
Sheets("Parameters").Select
decPlateNo = Cells(1, 2).Value
decStartrow = Cells(2, 2).Values
decStartcol = Cells(3, 2).Value
decColNo = Cells(4, 2).Value
decStep = Cells(5, 2).Value
decMEeff = 2.03
decM40eff = 4.37 'microscint 40=kind of solution the macrophages go in
decVolcorr = 2.4
decMxRNo = 8 * decColNo
ReDim vResMatrix(1 To decMxRNo, 1 To decPlateNo)
' Select QC (quality control) data
Sheets("Results QC").Select
For decInd1 = 1 To decPlateNo
decInd3 = decInd1 + 2
For decInd2 = 1 To iMxRNo
vResMatrix(decInd2, decInd1) = Cells(decInd2, decInd3).Value
Next decInd2
Next decInd1
' Transfer data for two methods of efflux calculations.
' Create template of columns.
Sheets("Processed indiv").Select
Range("C2:E87").Select
Selection.Copy
For decInd = 1 To decPlateNo / 2 - 1
decColIn = 3 + 3 * decInd
Cells(2, decColIn).Select
ActiveSheet.Paste
Next decInd
Application.CutCopyMode = False
' Don't cut and copy: leave the values in the Excel sheet.
' For disgorging values stored in matrix and calculate efflux.
For decInd1 = 1 To decPlateNo / 2
decColIn1 = 3 + 3 * (decInd1 - 1)
decColIn2 = decColIn1 + 1
decColIn3 = decColIn1 + 2
decBgrRow = (decInd1 - 1) * decStep * 2 + decStartrow + 8
decInd4 = 2 * decInd1
decInd3 = decInd4 - 1
Cells(1, decStartcol + 3 * (decInd1 - 1)).Value = "Plate " + CStr(decInd1)
' Get background value for the plate.
Sheets("Data").Select
decBgrValP = Cells(decBgrRow, 2)
Sheets("Processed indiv").Select
' Digorging values and calculating efflux.
For decInd2 = 1 To iMxRNo
decMediaVal = vResMatrix(decInd2, decInd3)
decMonoVal = vResMatrix(decInd2, decInd4)
Cells(2 + decInd2, decColIn1).Value = decMediaVal
Cells(2 + decInd2, decColIn2).Value = decMonoVal
Cells(2 + decInd2, decColIn3).Value = decMEeff * 100 * decVolcorr * (decMediaVal - decBgrValP) / (decM40eff * decMonoVal + decVolcorr * decMEeff * (decMediaVal - decBgrValP))
Next decInd2
Next decInd1
' Remove no data cells.
For decInd1 = 1 To decPlateNo / 2
decColIn1 = 3 + 3 * (decInd1 - 1)
For decInd2 = 3 To decMxRNo + 2
If Cells(decInd2, decColIn1).Value = "" Then
Cells(decInd2, decColIn1 + 1).Value = ""
Cells(decInd2, decColIn1 + 2).Value = ""
End If
Next decInd2
Next decInd1
' calculate data based on plate average.
' Create template for columns.
Sheets("Processed by plate").Select
Range("C2:E87").Select
Selection.Copy
For decInd = 1 To decPlateNo / 2 - 1
decColIn = 3 + 3 * decInd
Cells(2, decColIn).Select
ActiveSheet.Paste
Next decInd
Application.CutCopyMode = False
' Prep for disgorging values stored in matrix and calculate efflux.
For decInd1 = 1 To decPlateNo / 2
decColIn1 = 3 + 3 * (decInd1 - 1)
decColIn2 = decColIn1 + 1
decColIn3 = decColIn1 + 2
decBgrRow = (decInd1 - 1) * decStep * 2 + decStartrow + 8
decInd4 = 2 * decInd1
decInd3 = decInd4 - 1
Cells(1, decStartcol + 3 * (decInd1 - 1)).Value = "Plate " + CStr(decInd1)
' Get background value for the plate.
Sheets("Data").Select
decBgrValP = Cells(decBgrRow, 2)
Sheets("Processed by plate").Select
' Digorging values and calculating efflux.
' When does this for loop end?
For decInd2 = 1 To decMxRNo
Cells(2 + decInd2, decColIn1).Value = vResMatrix(decInd2, decInd3)
Cells(2 + decInd2, decColIn2).Value = vResMatrix(decInd2, decInd4)
Next decInd2
' Get average value for monolayer. (Cells are in 1-cell deep layer.) ?
decMonoVal = Cells(83, decColIn2).Value
For decInd2 = 1 To decMxRNo
decMediaVal = vResMatrix(decInd2, decInd3)
Cells(2 + decInd2, decColIn3).Value = decMEeff * 100 * decVolcorr * (decMediaVal - decBgrValP) / (decM40eff * decMonoVal + decVolcorr * decMEeff * (decMediaVal - decBgrValP))
Next decInd2
Next decInd1
' Remove no data cells.
For decInd1 = 1 To decPlateNo / 2
decColIn1 = 3 + 3 * (decInd1 - 1)
For decInd2 = 3 To decMxRNo + 2
If Cells(decInd2, decColIn1).Value = "" Then
Cells(decInd2, decColIn1 + 1).Value = ""
Cells(decInd2, decColIn1 + 2).Value = ""
End If
Next decInd2
Next decInd1
' Replace cell count data with calculated efflux in the matrix.
Sheets("Processed indiv").Select
For decInd1 = 1 To decPlateNo / 2
decColIn1 = 5 + 3 * (decInd1 - 1)
decInd4 = 2 * decInd1
For decInd2 = 1 To decMxRNo
vResMatrix(decInd2, decInd4) = Cells(2 + decInd2, decColIn1).Value
Next decInd2
Next decInd1
'Move data to duplicate comparison.
Sheets("Duplicate comparison").Select
Range("C2:N87").Select
Selection.Copy
For decInd = 1 To decPlateNo / 4 - 1
decColIn = 3 + 12 * decInd
Cells(2, decColIn).Select
ActiveSheet.Paste
Next decInd
Application.CutCopyMode = False
For decInd1 = 1 To decPlateNo / 4
decColIn1 = 3 + 12 * (decInd1 - 1)
decColIn2 = decColIn1 + 2
decColIn3 = decColIn1 + 3
decColIn4 = decColIn1 + 5
decInd3 = decInd1 * 4 - 3
decInd4 = decInd3 + 1
decInd5 = decInd3 + 2
decInd6 = decInd3 + 3
Cells(1, decStartcol + 12 * (decInd1 - 1)).Value = "Plate " + CStr(2 * decInd1 - 1)
Cells(1, decStartcol + 3 + 12 * (decInd1 - 1)).Value = "Plate " + CStr(2 * decInd1)
For iInd2 = 1 To iMxRNo
Cells(2 + iInd2, iColIn1).Value = vResMatrix(decInd2, decInd3)
Cells(2 + iInd2, iColIn2).Value = vResMatrix(decInd2, decInd4)
Cells(2 + iInd2, iColIn3).Value = vResMatrix(decInd2, decInd5)
Cells(2 + iInd2, iColIn4).Value = vResMatrix(decInd2, decInd6)
Next decInd2
Next decInd1
' Remove no data cells.
For decInd1 = 1 To decPlateNo / 4
decColIn1 = 3 + 12 * (decInd1 - 1)
decColIn2 = decColIn1 + 3
For decInd2 = 3 To decMxRNo + 2
If Cells(decInd2, decColIn1).Value = "" Then
Cells(decInd2, decColIn1 + 1).Value = ""
For decInd = 1 To 6
Cells(decInd2, decColIn1 + 5 + decInd).Value = ""
Next decInd
End If
If Cells(decInd2, decColIn2).Value = "" Then
Cells(decInd2, decColIn2 + 1).Value = ""
For decInd = 1 To 6
Cells(decInd2, decColIn2 + 2 + decInd).Value = ""
Next iInd
End If
Next decInd2
Next decInd1
' Prepare summary statistics.
decTL = decPlateNo * decMxRNo / 2
ReDim vResMatrix(1 To 4, 1 To iTL)
Sheets("Processed indiv").Select
decRowIn = 3 + decMxRNo
decRowIn2 = decRowIn + 1
For decInd1 = 1 To 3 * decPlateNo / 2
For decInd2 = 1 To 3
decRowIn3 = 3 * (decInd1 - 1) + iInd2
decColIn = 2 + decRowIn3
vResMatrix(1, decRowIn3) = Cells(decRowIn, decColIn).Value
vResMatrix(2, decRowIn3) = Cells(decRowIn2, decColIn).Value
Next decInd2
Next decInd1
Sheets("Processed by plate").Select
decRowIn = 3 + iMxRNo
decRowIn2 = decRowIn + 1
For decInd1 = 1 To 3 * decPlateNo / 2
For decInd2 = 1 To 3
decRowIn3 = 3 * (decInd1 - 1) + decInd2
decColIn = 2 + decRowIn3
vResMatrix(3, iRowIn3) = Cells(decRowIn, decColIn).Value
vResMatrix(4, decRowIn3) = Cells(decRowIn2, decColIn).Value
Next decInd2
Next decInd1
' Put summary statistics in distribution comp.
Sheets("Distribution comp").Select
For decInd = 1 To 3 * decPlateNo / 2
Cells(2 + iInd, 2).Value = vResMatrix(1, iInd)
Cells(2 + iInd, 3).Value = vResMatrix(2, iInd)
Cells(2 + iInd, 5).Value = vResMatrix(3, iInd)
Cells(2 + iInd, 6).Value = vResMatrix(4, iInd)
Next decInd
' Prepare plate by plate results.
Sheets("Duplicate comparison").Select
For decInd = 1 To iPlateNo / 4
decMatrixStep = (iInd - 1) * iMxRNo
decColIn = 9 + 12 * (iInd - 1)
decColIn2 = iColIn + 2
decColIn3 = iColIn + 1
decColIn4 = iColIn + 3
For decInd2 = 1 To decMxRNo
decMRow = iMatrixStep + decInd2
' Difference between duplicates converted into range.
vResMatrix(1, iMRow) = Cells(2 + decInd2, decColIn).Value
vResMatrix(2, iMRow) = Cells(2 + decInd2, decColIn2).Value / 2
vResMatrix(3, iMRow) = Cells(2 + decInd2, decColIn3).Value
vResMatrix(4, iMRow) = Cells(2 + decInd2, decColIn4).Value / 2
Next decInd2
Next decInd
' Transfer data to Summary.
Sheets("Summary").Select
' Prepare sheet.
Range("B3:G82").Select
Selection.Copy
For decInd = 1 To decPlateNo / 4 - 1
decRowIn = 3 + decMxRNo * iInd
decRangeNIn = "B" + CStr(decRowIn)
Range(decRangeNIn).Select
ActiveSheet.Paste
For decInd2 = 1 To decMxRNo
Cells(decInd2 + decRowIn - 1, 1).Value = "Plate " + CStr(decInd + 1)
Next decInd2
Next decInd
Application.CutCopyMode = False
' Don't cut and copy
' Distribute values.
For decInd = 1 To decTL
iRowIn = iInd + 2
Cells(decRowIn, 4).Value = vResMatrix(1, decInd)
Cells(decRowIn, 5).Value = vResMatrix(2, decInd)
Cells(decRowIn, 6).Value = vResMatrix(3, decInd)
Cells(decRowIn, 7).Value = vResMatrix(4, decInd)
Next decInd
' Transfer data to Matrix summary.
Sheets("Matrix summary").Select
' Prepare page for data.
Range("A1:M11").Select
Selection.Copy
For decInd = 1 To decPlateNo / 4 - 1
decRowIn = 1 + decStep * decInd
decRangeNIn = "A" + CStr(decRowIn)
Range(decRangeNIn).Select
ActiveSheet.Paste
Next decInd
Application.CutCopyMode = False
' Distribute data.
For decInd1 = 0 To iPlateNo / 4 - 1
decPlateStep = decStep * decInd1
decMatrixStep = iColNo * 8 * decInd1
For decInd2 = 0 To iColNo - 1
decColIn = decStartcol + decInd2
decColStep = 8 * iInd2
For iInd3 = 0 To 7
iRowIn = iStartrow + iPlateStep + iInd3
iMxElem = iMatrixStep + iColStep + iInd3 + 1
Cells(decRowIn, decColIn).Value = vResMatrix(3, iMxElem)
Next decInd3
Next decInd2
Next decInd1
' collect statistical parameters on efflux for unknown samples.
decRowNo = decPlateNo / 4
ReDim decEffluxMatrix(1 To iRowNo, 1 To 6)
decStartRowIn = 10
decStartColIn = 2
For decInd = 0 To iRowNo - 1
decRowIn = iStartRowIn + iStep * iInd
EffluxMatrix(iInd + 1, 1) = Cells(iRowIn, iStartColIn).Value
EffluxMatrix(iInd + 1, 2) = Cells(iRowIn + 1, iStartColIn).Value
Next decInd
'collect statistical parameters on efflux for control samples.
Sheets("Data").Select
decStartRowIn = 10
decStartColIn = 15
For iInd = 0 To iRowNo - 1
iRowIn = iStartRowIn + iStep * iInd * 4
EffluxMatrix(iInd + 1, 3) = Cells(iRowIn, iStartColIn).Value
EffluxMatrix(iInd + 1, 4) = Cells(iRowIn + 1, iStartColIn).Value
EffluxMatrix(iInd + 1, 5) = Cells(iRowIn + 22, iStartColIn).Value
EffluxMatrix(iInd + 1, 6) = Cells(iRowIn + 23, iStartColIn).Value
Next decInd
' Ouput of statistical parameters on efflux
Sheets("Matrix summary").Select
decStartRowOut = 4
decStartColOut = 15
For decInd1 = 1 To decRowNo
decRowOut = decStartRowOut + decInd1 - 1
For decInd2 = 1 To 6
decColOut = decStartColOut + decInd2 - 1
Cells(decRowOut, decColOut).Value = EffluxMatrix(decInd1, decInd2)
Next iInd2
Next decInd1
'Output into Matrix min-max
Sheets("Matrix min-max").Select
For decInd1 = 0 To decPlateNo / 4 - 1
decPlateStep = decStep * decInd1
decMatrixStep = decColNo * 8 * decInd1
For decInd2 = 0 To decColNo - 1
decColIn = decStartcol + iInd2
decColStep = 8 * decInd2
For decInd3 = 0 To 7
decRowIn = decStartrow + decPlateStep + decInd3
decMxElem = decMatrixStep + decColStep + decInd3 + 1
Cells(decRowIn, decColIn).Value = vResMatrix(3, decMxElem)
Next decInd3
Next decInd2
Next decInd1
ErrorHandler:
MsgBox "Error detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description, vbCritical, "Error Handler: Error " & Err.Number
MsgBox "If you want to force the program to run, go to the line below and insert a ' mark to comment the line out." & vbNewLine & "On Error GoTo ErrorHandler", vbCritical, "Error Handler: Error " & Err.Number
End Sub

You are attempting to use the variable vCPath before you have initialized it.

Related

My current code finds the vertex cover for five nodes. How would I generalize it to any number of nodes? Should I try recursion?

I am writing a code for a project that is trying to find the minimum solution to the Vertex Cover Problem: Given a graph, find the minimum number of vertices needed to cover the graph.
I am trying to write a program for a brute force search through the entire solution space. Right now, my code works by doing the following:
Example using 4 nodes:
Check Every Single Node: Solution Space: {1}, {2}, {3}, {4}
Check Every Couple of Nodes: Solution Space: {1,2}, {1,3}, {1,4}, {2,3}, {2,4}, {3,4}
Check Every Triple of Nodes: Solution Space: {1,2,3}, {1,2,4}, {2,3,4}
Check Every Quadruple of Nodes: Solution Space: {1,2,3,4}
Currently, my code works for 5 nodes. The problem is that it searches through these permutations using a fixed number of nested while loops. If I wanted to run 6 nodes, I would need to add in another While loop. I am trying to generalize the code so that the number of nodes can itself be a variable.
The code finds a solution by triggering a row of binary numbers based on the solution space above, eg if the solution being tried is {1,2,4} then the first, second, and fourth binary value will be set to equal 1 while the third is set to 0. A matrix is set up to use these inputs to determine if they cover the graph. Here is a picture further showing how this works.
Any ideas on how to generalize this to any number of nodes? Thoughts on recursion?
Also, note in the code there is a section that waits for 1 second. This is just for aesthetics, it is not serving any purpose besides making the code fun to watch.
i = 0
j = 0
k = 0
m = 0
Range("Z22").Select
While i < 5 'Checks to see if a single vertice can cover the graph.
Cells(5, 20 + i).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + i) = 0
i = i + 1
End If
Wend
i = 0
While i < 4 'Checks to see if two vertices can cover the graph
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
k = 0
While k < 3 'Checks to see if three vertices can cover the graph
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
While m < 2 'Checks to see if four vertices can cover the graph
Cells(5, 20 + m).Value = 1
k = m + 1
While k < 3
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
Cells(5, 20 + m).Value = 0
m = m + 1
Wend
If Cells(21, 13).Value <> Cells(22, 26).Value Then 'Final effort
Range("T5:X5") = 1
MsgBox ("It takes all five vertices.")
End If
Line1:
Application.DisplayAlerts = True
End Sub
This makes combinations for any n; does not use recursion. I've got to think if recursion would be applicable (make it simpler?)
Option Explicit
Const nnodes = 6
Dim a&(), icol&
Sub Main()
ThisWorkbook.Sheets("sheet1").Activate
Cells.Delete
Dim i&, j&
For i = 1 To nnodes ' from 1 to nnodes
ReDim a(i)
For j = 1 To i ' -- start with 1 up
a(j) = j
Next j
Cells(i, 1) = i ' show
icol = 2 ' for show
Do ' -- show combination and get next combination
Loop While doi(i)
Next i
End Sub
Function doi(i) As Boolean ' show and get next
Dim j&, s$
For j = 1 To i ' build string for show
If j > 1 Then s = s & ","
s = s & Str$(a(j))
Next j
Cells(i, icol) = "{" & s & "}" ' show
icol = icol + 1
' -- get next combination (if)
For j = i To 1 Step -1 ' check if any more
If a(j) < nnodes - i + j Then Exit For
Next j
If j < 1 Then doi = False: Exit Function ' no more
a(j) = a(j) + 1 ' build next combination
While j < i
a(j + 1) = a(j) + 1
j = j + 1
Wend
doi = True
End Function
EDIT: Changed "permutation" to "combination".
EDIT2: I kept coming back to recursion -- it does simplify the code:
Option Explicit
Dim icol& ' for showing combinations
Sub Main() ' get (non-empty) partitions of nnodes
Const nnodes = 6
Dim k&
ThisWorkbook.Sheets("sheet2").Activate
Cells.Delete
For k = 1 To nnodes ' k = 1 to n
Cells(k, 1) = k ' for showing
icol = 2
Call Comb("", 0, 1, nnodes, k) ' combinations(n,k)
Next k
End Sub
Sub Comb(s$, lens&, i&, n&, k&) ' build combination
Dim s2$, lens2&, j&
For j = i To n + lens + 1 - k '
If lens = 0 Then s2 = s Else s2 = s & ", "
s2 = s2 & j
lens2 = lens + 1
If lens2 = k Then ' got it?
Cells(k, icol) = "{" & s2 & "}" ' show combination
icol = icol + 1
Else
Call Comb(s2, lens2, j + 1, n, k) ' recurse
End If
Next j
End Sub

storing sheet data in temp memory for using that for comparing 2 excel

I have a VBA code to compare data from 2 sheets, so i have created the vba code but it is slow so i though to store sheet data in temp memory some how and instead switching sheets between it should use from temp memory.
My code-
For i = 2 To F1_iRowMax
Dim RV As Long
RV = 0
' On Error Resume Next
'RV = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 16384).Value, F2_Workbook.Sheets(ShName2).Range("XFD1:XFD1048576"), 0)
RV = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 16384).Value, KeyRange, 0)
On Error Resume Next
If Not IsError(RV) Then
Else
End If
Counter = 0
Counter = Counter + 1
pctdone = Counter / F1_iRowMax
With ufProgress
.LabelCaption.Caption = "Comparing Part-1 " & i & " of " & F1_iRowMax
.LabelProgress.Width = pctdone * (.FrameProgress.Width - 10)
End With
If RV <> 0 Then
''''F1 VS F2
' ColumnNumber = iCol_Max
'ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
For iCol = 1 To iCol_Max
F1_Data = F1_Workbook.Sheets(ShName).Cells(i, iCol)
F2_Data = F2_Workbook.Sheets(ShName2).Cells(RV, iCol)
'If i = 39100 Then Stop '''for debug
If F1_Data <> F2_Data Then
'
sIdx = sIdx + 1
' ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Address
ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Sheets(ShName).Cells(Header, iCol).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(i, 16384).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(i, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F1_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 5) = F2_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 6) = "Data Mismatch"
'ThisWorkbook.Sheets("Summary").Cells(sIdx, 3).Select
End If
Next iCol
Else
sIdx = sIdx + 1
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(i, 16384).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(i, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = "Record Exist"
ThisWorkbook.Sheets("Summary").Cells(sIdx, 6) = "No Record Found"
'ThisWorkbook.Sheets("Summary").Cells(sIdx, 3).Select
End If
Next i
I want to compare 40k rows between 2 sheets.

CountIf Application or object defined error

I've got a code that keeps on returning a run-time error 1004 - Application-defined or object-defined error. I've tried stepping through the individual parts of the worksheetfunction.countif function, and they all work fine separately.
However, when I put them together, they fail.
The code is:
s = 2
While Cells(s - 1, 1) <> vbNullString
Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(s, 1), Cells(s + 3, 1)).Select
Selection.Rows.Group
Cells(s, 1) = "A"
Cells(s + 1, 1) = "B"
Cells(s + 2, 1) = "C"
Cells(s + 3, 1) = "D"
r = 3
q = vbNullString
p = vbNullString
n = s
While n < s + 5
While r <= v
M = 1
If Cells(n, 1) = "A" Then
q = 5
p = 12
ElseIf Cells(n, 1) = "B" Then
q = 18
p = 25
ElseIf Cells(n, 1) = "C" Then
q = 31
p = 38
ElseIf Cells(n, 1) = "D" Then
q = 44
p = 51
End If
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))
If Not IsError(l) Then
Cells(n, r) = l
Else
Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
Wend
n = n + 1
r = 3
Wend
s = s + 5
Wend
All variables have been declared as Variants.
Edit: for clarity. Error occurs at:
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))
The problem is the way you declare the ranges. You should always include the sheet, otherwise you get this error, if you use more than one sheet (or if you use one, but it is not the active one).
Like this:
With ActiveSheet
While Cells(s - 1, 1) <> vbNullString
.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range(.Cells(s, 1), .Cells(s + 3, 1)).Select
Selection.Rows.Group
.Cells(s, 1) = "A"
.Cells(s + 1, 1) = "B"
.Cells(s + 2, 1) = "C"
.Cells(s + 3, 1) = "D"
Wend
End With
Pay attention to the dots.
In general, declare the sheets and then use them:
'Option Explicit - start using option explicit
Sub test()
Dim wksA As Worksheet
Dim wksIT As Worksheet
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
s = 2
While Cells(s - 1, 1) <> vbNullString
wksA.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wksA.Range(wksA.Cells(s, 1), wksA.Cells(s + 3, 1)).Select
Selection.Rows.Group
wksA.Cells(s, 1) = "A"
wksA.Cells(s + 1, 1) = "B"
wksA.Cells(s + 2, 1) = "C"
wksA.Cells(s + 3, 1) = "D"
Wend
With wksIT
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(.Range(.Cells(q, M), _
.Cells(p, M)), .Cells(s + 4, 1))
If Not IsError(l) Then
.Cells(n, r) = l
Else
.Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
End With
End Sub
Concerning your case, I am about 80% sure, that you get the error somewhere here:
l = WorksheetFunction.CountIf(Range(Cells(q, M), Cells(p, M)), Cells(s + 4, 1))
In general, never assume which worksheet your code is operating on and explicitly define it in your code.
Concerning the place where you get the error, it should be simply like this:
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
Set wksPl = ThisWorkbook.Worksheets("SomePlayers")
l = WorksheetFunction.CountIf(wksIT.Range(wksIT.Cells(q, M), wksIT.Cells(p, M)), _
wksPl.Cells(s + 4, 1))

Error 400, 1004 in VBA-Excel

I am trying to use a macro written and shared as the supplemental material of a scientific paper published in 1999.
I believe the macro has been written under Excel 1997 environment.
Unfortunately, I have very poor knowledge of VBA-Excel, and as far as I could understand, there might be a problem regarding the call of method .Select or .Range for the ActiveSheet, due to/along with an incompatibility between Excel 1997 and nowadays Excel 2010 (the one I am using).
It seems that VBA-Excel environment has quite a powerful debugging interface, although my poor knowledge of this language doesn't provide sufficient understanding to debug by myself.
My question is: can you try to run the macro, face the bug and corresponding error message, and fix (or help me fixing) the code?
Thank you very much.
Here is the macro:
'
'PSD MACRO
'Macro 7/24/97 by Wayne Lukens
'
'New Sheet Column assignments
'1 - Pressure, Pr = p/p0
'2 - Gas Volume adsorbed, Vg
'3 - Volume adsorbed as liquid, V1
'4 - Critical thickness, Tcr
'5 - Critical Radius, Rcr
'6 - Critical Pressure for Rave, Pave
'7 - Critical Thickness for Rave, Pave
'8 - Average Pore Radius, Rave
'9 - Average Pore Diameter, Dave
'10 - Volume of the Kelvin cores, Vc
'11 - Cross Sectional Area
'12 - Number of pores at a given pressure, Lp
'13 - Total volume of pores of radius Rave, Vc
'14 - Volume of gas desorbed in a step, Vd
'15 - Dave again
'
Sub PSD()
'
'Set up variables
'
Dim Pr(100), Rcr(100), V1(100), Tcr(100), Vd(100), Csa(100), Vc(100), Pave(100)
Dim PoreV(100), Lp(100), Tave(100), Rc(100), Rave(100), Te(100, 100)
Dim Te1 As String
Dim C(10), T, f, df, dx, Tlast As Double
PageTitle = "Adsorp in "
MeniscusTitle = "Hemisperical Meniscus"
Pi = 3.14159
a = 5 * (3.54 ^ 3)
' factoroot = 4.05*Log(10)
R = 0.8314
T = 77.2
RT = R * T
Gamma = 8.72
Vm = 34.68
factoroot = 2 * Gamma * Vm / (R * T)
PoreType = ""
' Welcome = MsgBox("Welcome to Broekhoff-de-Boer analysis with a Frenkel-Halsey-Hill isotherm.",vbOKOnly)
On Error Resume Next
Set dData = Application.InputBox("Please select the cells which contain your isotherm data. The data must " & "contain p/p0 in column 1 and the volume of gas adsorbed (as gas) in column 2.", "Select Isotherm Data", Type:=8)
If Err <> 0 Then
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
'
'Get information from the user to determine pore model and meniscus shape
'
Do Until PoreType = "sphere" Or PoreType = "s" Or PoreType = "cylinder" Or PoreType = "c" Or PoreType = False
PoreType = Application.InputBox("Which pore model are you using, cylinder or sphere (c or s)?", "Pore Model")
Loop
If PoreType = False Then
Exit Sub
End If
answer1 = MsgBox("Is this an adsorption isotherm?", vbYesNo)
Answer2 = MsgBox("Does the isotherm display hysteresis?", vbYesNo)
alpha = InputBox("What is the value of the FHH parameter, alpha? (Default = 5*3.54^3)", "Enter alpha", a)
If answer1 = vbNo Then
PoreType = "c"
PageTitle = "Desorp from"
End If
If PoreType = "sphere" Or PoreType = "s" Then
ModelSheet = "Spheres"
PoreType = "s"
factory = factoroot
PoreTitle = "Spherical Pores"
Else
ModelSheet = "Cylinders"
PoreType = "c"
factory = factoroot / 2
PoreTitle = "Cylindrical Pores"
End If
If Answer2 = vbNo Then ModelSheet = ModelSheet & "no Hy"
If alpha = "" Then
Exit Sub
End If
If answer1 = vbYes Then
celltitle = "Adsorption in " & ModelSheet
Else
celltitle = "Desorption from " & ModelSheet
End If
ModelSheet = PageTitle & ModelSheet
'
'Copy selected data to new sheets.
'
ActiveSheet.Activate
dData.Select
Selection.Copy
'Application.Workbook.Add
ActiveSheet.Activate
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = ModelSheet
Sheets(ModelSheet).Activate
Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBotom
'
'Convert gas volumes into liquid volumes
'
iRows = Selection.Rows.Count
Cells(1, 3).Formula = " =B1*0.0015468"
Cells(1, 3).Select
Selection.AutoFill Destination:=Range(Cells(1, 3), Cells(iRows, 3)), Type:=x1FillDefault
'
'Fill array
'
For I = 1 To iRows
Pr(I) = Cells(I, 1)
V1(I) = Cells(I, 3)
Next I
If answer1 = vbNo Or Answer2 = vbNo Then
'
'Calculate Critical Radius and Pore Diameter at each Pressure for a Desorption Branch
'
If answer1 = vbNo Then
BranchTitle = "Desorption from"
Else
BranchTitle = "Adsorption w/o Hysteresis" & Chr(13) & "in"
End If
fa = factoroot / 2
For I = 1 To iRows
Inp = -Log(Pr(I))
THigh = 5 * (alpha / Inp) ^ (1 / 3)
TLow = 0.5 * (alpha / Inp) ^ (1 / 3)
T = 3 * (alpha / Inp) ^ (1 / 3)
C(1) = alpha * alpha / Inp
C(2) = 0#
C(3) = -2 * alpha * fa / Inp
C(4) = -2 * alpha
C(5) = 0#
C(6) = fa
C(7) = Inp
For K = 1 To 20
f = C(1) + T * T * (C(3) + T * (C(4) + T * T * (C(6) + T * C(7))))
df = T * (2 * C(3) + T * (3 * C(4) + T * T * (5 * C(6) + T * 6 * C(7))))
dx = f / df
If dx > 0 Then
THigh = T
End If
If dx < 0 Then
TLow = T
End If
T = T - dx
If (Abs(dx) < 0.00000000000001) Then Exit For
If T > THigh Then
T = (THigh + Tlast) / 2
End If
If T < TLow Then
T = (TLow + Tlast / 2)
End If
Tlast = T
Next K
Tcr(I) = T
Cells(I, 4) = T
Rcr(I) = Tcr(I) + fa / (Inp - alpha / (Tcr(I) ^ 3))
Next I
Else
'
'Calculate Critical Radius and Pore Diameter at each pressure for an Adsorption Branch
'
If PoreType = "c" Then MeniscusTitle = "Cylindrical Meniscus"
BranchTitle = "Adsorption in"
For I = 1 To iRows
logprel = Log(Pr(I))
q = -((alpha * factory / 3) ^ 0.5) / logprel
R = alpha / (2 * logprel)
If R ^ 2 < q ^ 3 Then
x = R / Sqr(q ^ 3)
theta = Atn(-x / Sqr(-x * x + 1)) + 1.5708
root2 = -2 * Sqr(q) * Cos((theta + 2 * 3.14159) / 3)
Tcr(I) = root2
Else
a = -Sgn(R) * (Abs(R) + Sqr(R ^ 2 - q ^ 3)) ^ (1 / 3)
b = q / a
Tcr(I) = a + b
End If
Rcr(I) = Tcr(I) + factory / (-logprel - alpha / Tcr(I) ^ 3)
Next I
End If
'
'Calculate the average pore radius for this desorption step
'
For I = 1 To iRows - 1
Rave(I) = (Rcr(I) + Rcr(I + 1)) * Rcr(I) * Rcr(I + 1) / (Rcr(I) ^ 2 + Rcr(I + 1) ^ 2)
'
'Calculate the critical thickness and pressure for each Rave since Rave is known
'
a = Sqr(factory)
b = Sqr(3 * alpha)
d = -Rave(I) * b
q = -0.5 * (b + Sgn(b) * Sqr(b ^ 2 - 4 * a * d))
Tave(I) = d / q
Pave(I) = Exp(-(factory / (Rave(I) - Tave(I)) + alpha / Tave(I) ^ 3))
Next I
'
'Calculate Equilibrium Thickness at every pressure for each pore radius using the Newton-Raphson method
'
C(2) = alpha
C(3) = 0#
For I = 2 To iRows
Rcrit = Rave(I - 1)
C(1) = -alpha * Rcrit
T = Tcr(I)
For J = I + 1 To iRows + 1
Prel = Pr(J - 1)
Plog = -Log(Prel)
C(5) = -Plog
C(4) = Rcrit * Plog - factory
For K = 1 To 20
f = C(1) + T * (C(2) + T ^ 2 * (C(4) + T * C(5)))
df = C(2) + T * (T * (3 * C(4) + T * 4 * C(5)))
dx = f / df
T = T - dx
If (Abs(dx) < 0.0000000001) Then Exit For
Next K
Te(J - 1, I - 1) = T
Next J
Next I
'
'Do the iterative part of the analysis
'
For I = 1 To iRows - 1
'
'Calculate volume change for all previously opened pores
'
Vd(I) = 0#
If I = 1 Then
Vd(I) = 0#
Else
For J = 1 To I - 1
'
'Calculate the total volume desorbed from the open pores during this interval
'
If PoreType = "s" Then
Vd(I) = Vd(I) + 1E-24 * (4 / 3) * Pi * ((Rave(J) - Te(I + 1, J)) ^ 3 - (Rave(J) - Te(I, J)) ^ 3) * Lp(J)
'Note : In this case, Lp(J) is the number of spherical pores
Else
If PoreType = "c" Then
Vd(I) = Vd(I) + 1E-16 * Pi * ((Rave(J) - Te(I + 1, J)) ^ 2 - (Rave(J) - Te(I, J)) ^ 2) * Lp(J)
'Note : in this case, Lp(J) is the length of the cylindrical pore in cm.
Else
sorry = MsgBox("error at Vd(I) stae", vbOKOnly)
Exit Sub
End If
End If
Next J
End If
'
'Determine what's going on
'
If Vd(I) >= (V1(I) - V1(I + 1)) Then
'
'The volume desorbed is less than the volume expected from desorption from opened pores, set the volume of the new pores to zero
'
'
Lp(I) = 0#
Vc(I) = 0#
Csa(I) = 0#
Else
'
'The volume desorbed is greater thant the volume expected, so the new pores must have opened
'
Vc(I) = V1(I) - V1(I + 1) + Vd(I)
'
'Calculate the volume of the newly opened pores in cm3 at the end of the interval
'
If PoreType = "s" Then
Csa(I) = 4E-24 * (Pi / 3) * (Rave(I) - Te(I + 1, I)) ^ 3
Else
If PoreType = "c" Then
Csa(I) = Pi * 1E-16 * (Rave(I) - Te(I + 1, I)) ^ 2
Else
sorry = MsgBox("error at Csa calculation", vbOKOnly)
Exit Sub
End If
End If
'
'Calculate the number of pores
'
Lp(I) = Vc(I) / Csa(I)
End If
'
'Write values of important numbers to the worksheet"
'
If PoreType = "s" Then
PoreV(I) = 4E-24 * (Pi / 3) * Lp(I) * Rave(I) ^ 3
Else
If PoreType = "c" Then
PoreV(I) = 1E-16 * Lp(I) * Pi * Rave(I) ^ 2
Else
sorry = MsgBox("error at PoreV calculation", vbOKOnly)
Exit Sub
End If
End If
Next I
'
'Do calculations for Incremental Pore Volumee
'
Bigpoint = 0
BigPointNumber = 1
CumSA = 0
CumPV = 0
For J = 1 To iRows - 1
Cells(J, 4) = Tcr(J)
Cells(J, 5) = Rcr(J)
Cells(J, 6) = Pave(J)
Cells(J, 7) = Tave(J)
Cells(J, 8) = Rave(J)
Cells(J, 9) = Rave(J) * 2
Cells(J, 10) = Vc(J)
Cells(J, 11) = Csa(J)
Cells(J, 12) = Lp(J)
Cells(J, 13) = PoreV(J)
Cells(J, 14) = Vd(J)
Cells(J, 15) = Rave(J) * 2
Cells(J, 16) = PoreV(J)
If Rave(J) < 10 Then Exit For
If Cells(J, 16) > Bigpoint Then
BigPointNumber = J
Bigpoint = Cells(J, 16)
End If
'
'Calculate Surface Area in m2/g
'
If PoreType = "s" Then
Cells(J, 17) = 4E-20 * Pi * Lp(J) * Rave(J) ^ 2
Else
If PoreType = "c" Then
Cells(J, 17) = 0.000000000002 * Pi * Lp(J) * Rave(J)
Else
sorry = MsgBox("Error at cumulative surface area calculation", vbOKOnly)
Exit Sub
End If
End If
CumSA = CumSA + Cells(J, 17)
CumPV = CumPV + PoreV(J)
Cells(J, 18) = CumSA
Cells(J, 19) = CumPV
Next J
'
'Give Cells Headings
'
Cells(1, 1).Select
Selection.EntireRow.Insert
Cells(1, 1) = "Rel pres"
Cells(1, 2) = "Vol as gas"
Cells(1, 3) = "vol as liq"
Cells(1, 4) = "Crit thick"
Cells(1, 5) = "Crit radius"
Cells(1, 6) = "Avg pres"
Cells(1, 7) = "Avg thick"
Cells(1, 8) = "Avg radius"
Cells(1, 9) = "Avg diam"
Cells(1, 10) = "Vol cores"
Cells(1, 11) = "X sect area"
Cells(1, 12) = "Pore length"
Cells(1, 13) = celltitle
Cells(1, 14) = "Vol desorp"
Cells(1, 15) = "Avg diam"
Cells(1, 16) = celltitle
Cells(1, 17) = "Surf area"
Cells(1, 18) = "Cumul SA"
Cells(1, 19) = "Cumul PoreV"
SurfaceArea = Fix(CumSA + 0.5)
PoreVolume = Fix(100 * CumPV + 0.5) / 100
'
'Create a chart
'
Columns("O:O").Select
Selection.NumberFormat = "0"
Charts.Add
ActiveChart.ChartWizard Source:=Sheets(ModelSheet).Range("$O:$P"), Gallery:=xlXYScatter, Format:=2, PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=2, Title:="Plot for" & celltitle, CategoryTitle:="Pore Diameter in Angstroms", ValueTitle:="Pore Volume in cc per gram", ExtraTitle:=""
ActiveChart.PlotArea.Select
Nombre = ModelSheet & "Plot"
ActiveSheet.Name = Nombre
End Sub
One can try the macro with the following set of data to embed in the sheet:
0.0106908 103.046
0.031249 120.144
0.0515578 129.808
0.0772499 138.616
0.100304 144.98
0.120399 149.797
0.140559 154.187
0.160819 158.255
0.18104 162.065
0.20132 165.698
0.24889 173.67
0.278214 178.398
0.303499 182.434
0.350487 189.809
0.375365 193.778
0.400622 197.828
0.425556 201.949
0.450624 206.146
0.475636 210.459
0.50072 214.991
0.525794 219.652
0.550631 224.562
0.575897 229.666
0.600643 235.066
0.625847 240.934
0.650973 247.074
0.675899 253.657
0.701025 260.816
0.725913 268.534
0.75098 277.212
0.776003 287.031
0.801318 298.016
0.813639 304.484
0.826658 311.591
0.838517 318.99
0.851442 327.799
0.863629 337.611
0.876573 349.305
0.888307 362.915
0.900328 383.552
0.911067 419.354
0.92187 475.714
0.952079 631.959
0.97104 817.134
0.979005 1038.01
0.984323 1250.95
0.99039 1436.81
Thanks again.
Here's an updated version of the code. I've done the following:
Declared and sorted all variables
Given the code a good structure (tab-wise)
Made the code run in background (speeded up code from 10s to >1s)
The code begins with removing old data (generated charts and sheets)
Option Explicit
' Books & Sheets
Dim Wb1 As Workbook
Dim Sh1 As Worksheet, Sh2 As Worksheet
' Doubles: One letter
Dim A As Double, B As Double, D As Double, F As Double, J As Double, K As Double
Dim R As Double, Q As Double, T As Double, X As Double
' Doubles: Two letters
Dim dF As Double, dX As Double, fA As Double, Vm As Double, Rt As Double, Pi As Double
' Doubles: Three or more letters
Dim Alpha As Double, BigPoint As Double, BigPointNumber As Double, CumSA As Double, CumPV As Double
Dim Factory As Double, Gamma As Double, Inp As Double, LogpRel As Double, pLog As Double
Dim PoreVolume As Double, pRel As Double, rCrit As Double, Root2 As Double, SurfaceArea As Double
Dim Theta As Double, tHigh As Double, tLast As Double, tLow As Double
' Doubles: Arrays
Dim C(10) As Double, Csa(100) As Double, Lp(100) As Double, Pave(100) As Double, PoreV(100) As Double
Dim Pr(100) As Double, Rave(100) As Double, Rc(100) As Double, Rcr(100) As Double, Tave(100) As Double
Dim Tcr(100) As Double, Te(100, 100) As Double, V1(100) As Double, Vc(100) As Double, Vd(100) As Double
' Longs
Dim i&, iRows&
' Strings ($)
Dim BranchTitle$, CellTitle$, FactoRoot$, MeniscusTitle$, ModelSheet$
Dim PageTitle$, PoreTitle$, PoreType$, Spheres$, Te1$
' Booleans (True or False)
Dim Answer1 As Boolean, Answer2 As Boolean
' Range
Dim dData As Range
' PSD MACRO
' Macro 7/24/97 by Wayne Lukens
'
' New Sheet Column assignments
' 1 - Pressure, Pr = p/p0
' 2 - Gas Volume adsorbed, Vg
' 3 - Volume adsorbed as liquid, V1
' 4 - Critical thickness, Tcr
' 5 - Critical Radius, Rcr
' 6 - Critical Pressure for Rave, Pave
' 7 - Critical Thickness for Rave, Pave
' 8 - Average Pore Radius, Rave
' 9 - Average Pore Diameter, Dave
' 10 - Volume of the Kelvin cores, Vc
' 11 - Cross Sectional Area
' 12 - Number of pores at a given pressure, Lp
' 13 - Total volume of pores of radius Rave, Vc
' 14 - Volume of gas desorbed in a step, Vd
' 15 - Dave again
Sub PSD()
' Declare books and sheets
Set Wb1 = ThisWorkbook
Set Sh1 = Wb1.Sheets("Data")
' Delete old sheets if existing (graph and database)
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Sheets("Adsorp in Cylinders").Delete
Sheets("Adsorp in Spheres").Delete
Sheets("Adsorp in CylindersPlot").Delete
Sheets("Adsorp in SpheresPlot").Delete
Sheets("CylindersPlot").Delete
Sheets("SpheresPlot").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Set up variables
PageTitle = "Adsorp in "
MeniscusTitle = "Hemisperical Meniscus"
Pi = WorksheetFunction.Pi
A = 5 * (3.54 ^ 3)
' factoroot = 4.05*Log(10)
R = 0.8314
T = 77.2
Rt = R * T
Gamma = 8.72
Vm = 34.68
FactoRoot = 2 * Gamma * Vm / (R * T)
PoreType = ""
' Welcome = MsgBox("Welcome to Broekhoff-de-Boer analysis with a Frenkel-Halsey-Hill isotherm.",vbOKOnly)
On Error Resume Next
Set dData = Application.InputBox("Please select the cells which contain your isotherm data." & _
"The data must " & "contain p/p0 in column 1 and the volume of gas adsorbed (as gas) in column 2.", _
"Select Isotherm Data", Type:=8)
If Err <> 0 Then
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
' Run everything in background (code runs faster)
Application.ScreenUpdating = False
Set dData = dData.SpecialCells(xlCellTypeConstants) ' Removes all cells but constants from selection
' Get information from the user to determine pore model and meniscus shape
Do Until PoreType = "sphere" Or PoreType = "s" Or PoreType = "cylinder" Or PoreType = "c"
PoreType = Application.InputBox("Which pore model are you using, cylinder or sphere (c or s)?", "Pore Model")
If PoreType = "" Then Exit Sub
Loop
Answer1 = MsgBox("Is this an adsorption isotherm?", vbYesNo)
Answer2 = MsgBox("Does the isotherm display hysteresis?", vbYesNo)
Alpha = InputBox("What is the value of the FHH parameter, alpha? (Default = 5*3.54^3)", "Enter alpha", A)
If Answer1 = False Then
PoreType = "c"
PageTitle = "Desorp from"
End If
If PoreType = "sphere" Or PoreType = "s" Then
ModelSheet = "Spheres"
PoreType = "s"
Factory = FactoRoot
PoreTitle = "Spherical Pores"
Else
ModelSheet = "Cylinders"
PoreType = "c"
Factory = FactoRoot / 2
PoreTitle = "Cylindrical Pores"
End If
If Answer2 = False Then ModelSheet = ModelSheet & "no Hy"
If Alpha = 0 Then Exit Sub
If Answer1 = True Then
CellTitle = "Adsorption in " & ModelSheet
Else
CellTitle = "Desorption from " & ModelSheet
End If
' Copy selected data to new sheets
dData.Copy
Sheets.Add After:=Sh1
ActiveSheet.Paste
ActiveSheet.Name = PageTitle & ModelSheet
Set Sh2 = Wb1.Sheets(PageTitle & ModelSheet)
Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Convert gas volumes into liquid volumes
iRows = Selection.Rows.Count
Cells(1, 3).Formula = "=B1*0.0015468"
Range(Cells(2, 3), Cells(iRows, 3)).Formula = Cells(1, 3).Formula
' Fill array
For i = 1 To iRows
Pr(i) = Cells(i, 1)
V1(i) = Cells(i, 3)
Next i
If Answer1 = False Or Answer2 = False Then
' Calculate Critical Radius and Pore Diameter at each Pressure for a Desorption Branch
If Answer1 = vbNo Then
BranchTitle = "Desorption from"
Else
BranchTitle = "Adsorption w/o Hysteresis" & Chr(13) & "in"
End If
fA = FactoRoot / 2
For i = 1 To iRows
Inp = -Log(Pr(i))
tHigh = 5 * (Alpha / Inp) ^ (1 / 3)
tLow = 0.5 * (Alpha / Inp) ^ (1 / 3)
T = 3 * (Alpha / Inp) ^ (1 / 3)
C(1) = Alpha * Alpha / Inp
C(2) = 0#
C(3) = -2 * Alpha * fA / Inp
C(4) = -2 * Alpha
C(5) = 0#
C(6) = fA
C(7) = Inp
For K = 1 To 20
F = C(1) + T * T * (C(3) + T * (C(4) + T * T * (C(6) + T * C(7))))
dF = T * (2 * C(3) + T * (3 * C(4) + T * T * (5 * C(6) + T * 6 * C(7))))
dX = F / dF
If dX > 0 Then tHigh = T
If dX < 0 Then tLow = T
T = T - dX
If (Abs(dX) < 0.00000000000001) Then Exit For
If T > tHigh Then T = (tHigh + tLast) / 2
If T < tLow Then T = (tLow + tLast / 2)
tLast = T
Next K
Tcr(i) = T
Cells(i, 4) = T
Rcr(i) = Tcr(i) + fA / (Inp - Alpha / (Tcr(i) ^ 3))
Next i
Else
' Calculate Critical Radius and Pore Diameter at each pressure for an Adsorption Branch
If PoreType = "c" Then MeniscusTitle = "Cylindrical Meniscus"
BranchTitle = "Adsorption in"
For i = 1 To iRows
LogpRel = Log(Pr(i))
Q = -((Alpha * Factory / 3) ^ 0.5) / LogpRel
R = Alpha / (2 * LogpRel)
If R ^ 2 < Q ^ 3 Then
X = R / Sqr(Q ^ 3)
Theta = Atn(-X / Sqr(-X * X + 1)) + 1.5708
Root2 = -2 * Sqr(Q) * Cos((Theta + 2 * 3.14159) / 3)
Tcr(i) = Root2
Else
A = -Sgn(R) * (Abs(R) + Sqr(R ^ 2 - Q ^ 3)) ^ (1 / 3)
B = Q / A
Tcr(i) = A + B
End If
Rcr(i) = Tcr(i) + Factory / (-LogpRel - Alpha / Tcr(i) ^ 3)
Next i
End If
' Calculate the average pore radius for this desorption step
For i = 1 To iRows - 1
Rave(i) = (Rcr(i) + Rcr(i + 1)) * Rcr(i) * Rcr(i + 1) / (Rcr(i) ^ 2 + Rcr(i + 1) ^ 2)
' Calculate the critical thickness and pressure for each Rave since Rave is known
A = Sqr(Factory)
B = Sqr(3 * Alpha)
D = -Rave(i) * B
Q = -0.5 * (B + Sgn(B) * Sqr(B ^ 2 - 4 * A * D))
Tave(i) = D / Q
Pave(i) = Exp(-(Factory / (Rave(i) - Tave(i)) + Alpha / Tave(i) ^ 3))
Next i
'Calculate Equilibrium Thickness at every pressure for each pore radius using the Newton-Raphson method
C(2) = Alpha
C(3) = 0#
For i = 2 To iRows
rCrit = Rave(i - 1)
C(1) = -Alpha * rCrit
T = Tcr(i)
For J = i + 1 To iRows + 1
pRel = Pr(J - 1)
pLog = -Log(pRel)
C(5) = -pLog
C(4) = rCrit * pLog - Factory
For K = 1 To 20
F = C(1) + T * (C(2) + T ^ 2 * (C(4) + T * C(5)))
dF = C(2) + T * (T * (3 * C(4) + T * 4 * C(5)))
dX = F / dF
T = T - dX
If (Abs(dX) < 0.0000000001) Then Exit For
Next K
Te(J - 1, i - 1) = T
Next J
Next i
' Do the iterative part of the analysis
For i = 1 To iRows - 1
' Calculate volume change for all previously opened pores
Vd(i) = 0#
If i = 1 Then
Vd(i) = 0#
Else
For J = 1 To i - 1
' Calculate the total volume desorbed from the open pores during this interval
If PoreType = "s" Then
Vd(i) = Vd(i) + 1E-24 * (4 / 3) * Pi * ((Rave(J) - Te(i + 1, J)) ^ 3 - (Rave(J) - Te(i, J)) ^ 3) * Lp(J)
' Note : In this case, Lp(J) is the number of spherical pores
Else
If PoreType = "c" Then
Vd(i) = Vd(i) + 1E-16 * Pi * ((Rave(J) - Te(i + 1, J)) ^ 2 - (Rave(J) - Te(i, J)) ^ 2) * Lp(J)
' Note : in this case, Lp(J) is the length of the cylindrical pore in cm.
Else
MsgBox "Error at Vd(I) stae", vbOKOnly
Exit Sub
End If
End If
Next J
End If
' Determine what's going on
If Vd(i) >= (V1(i) - V1(i + 1)) Then
' The volume desorbed is less than the volume expected from desorption from opened pores, set the volume of the new pores to zero
Lp(i) = 0#
Vc(i) = 0#
Csa(i) = 0#
Else
' The volume desorbed is greater thant the volume expected, so the new pores must have opened
Vc(i) = V1(i) - V1(i + 1) + Vd(i)
' Calculate the volume of the newly opened pores in cm3 at the end of the interval
If PoreType = "s" Then
Csa(i) = 4E-24 * (Pi / 3) * (Rave(i) - Te(i + 1, i)) ^ 3
Else
If PoreType = "c" Then
Csa(i) = Pi * 1E-16 * (Rave(i) - Te(i + 1, i)) ^ 2
Else
MsgBox "Error at Csa calculation", vbOKOnly
Exit Sub
End If
End If
' Calculate the number of pores
Lp(i) = Vc(i) / Csa(i)
End If
' Write values of important numbers to the worksheet
If PoreType = "s" Then
PoreV(i) = 4E-24 * (Pi / 3) * Lp(i) * Rave(i) ^ 3
Else
If PoreType = "c" Then
PoreV(i) = 1E-16 * Lp(i) * Pi * Rave(i) ^ 2
Else
MsgBox "Error at PoreV calculation", vbOKOnly
Exit Sub
End If
End If
Next i
'Do calculations for Incremental Pore Volumee
BigPoint = 0
BigPointNumber = 1
CumSA = 0
CumPV = 0
For J = 1 To iRows - 1
Cells(J, 4) = Tcr(J)
Cells(J, 5) = Rcr(J)
Cells(J, 6) = Pave(J)
Cells(J, 7) = Tave(J)
Cells(J, 8) = Rave(J)
Cells(J, 9) = Rave(J) * 2
Cells(J, 10) = Vc(J)
Cells(J, 11) = Csa(J)
Cells(J, 12) = Lp(J)
Cells(J, 13) = PoreV(J)
Cells(J, 14) = Vd(J)
Cells(J, 15) = Rave(J) * 2
Cells(J, 16) = PoreV(J)
If Rave(J) < 10 Then Exit For
If Cells(J, 16) > BigPoint Then
BigPointNumber = J
BigPoint = Cells(J, 16)
End If
'Calculate Surface Area in m2/g
If PoreType = "s" Then
Cells(J, 17) = 4E-20 * Pi * Lp(J) * Rave(J) ^ 2
Else
If PoreType = "c" Then
Cells(J, 17) = 0.000000000002 * Pi * Lp(J) * Rave(J)
Else
MsgBox "Error at cumulative surface area calculation", vbOKOnly
Exit Sub
End If
End If
CumSA = CumSA + Cells(J, 17)
CumPV = CumPV + PoreV(J)
Cells(J, 18) = CumSA
Cells(J, 19) = CumPV
Next J
'Give Cells Headings
Rows(1).Insert
Cells(1, 1) = "Rel pres"
Cells(1, 2) = "Vol as gas"
Cells(1, 3) = "vol as liq"
Cells(1, 4) = "Crit thick"
Cells(1, 5) = "Crit radius"
Cells(1, 6) = "Avg pres"
Cells(1, 7) = "Avg thick"
Cells(1, 8) = "Avg radius"
Cells(1, 9) = "Avg diam"
Cells(1, 10) = "Vol cores"
Cells(1, 11) = "X sect area"
Cells(1, 12) = "Pore length"
Cells(1, 13) = CellTitle
Cells(1, 14) = "Vol desorp"
Cells(1, 15) = "Avg diam"
Cells(1, 16) = CellTitle
Cells(1, 17) = "Surf area"
Cells(1, 18) = "Cumul SA"
Cells(1, 19) = "Cumul PoreV"
SurfaceArea = Fix(CumSA + 0.5)
PoreVolume = Fix(100 * CumPV + 0.5) / 100
'Create a chart
Columns("O:O").NumberFormat = "0"
Range("A1").Select
ActiveSheet.UsedRange.Columns.AutoFit
Charts.Add After:=Sh1
ActiveChart.ChartWizard Source:=Sheets(PageTitle & ModelSheet).Range("$O:$P"), Gallery:=xlXYScatter, _
Format:=2, PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=2, _
Title:="Plot for" & CellTitle, CategoryTitle:="Pore Diameter in Angstroms", _
ValueTitle:="Pore Volume in cc per gram", ExtraTitle:=""
ActiveSheet.Name = ModelSheet & "Plot"
Calculate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Couple of simple issues:
Cells(1, 3).Formula = " =B1*0.0015468"
needs to be:
Cells(1, 3).Formula = "=B1*0.0015468"
without the space before the '=' sign.
Also,
xlTopToBotom is misspelled - it needs to be xlTopToBottom. Similarly, x1FillDefault needs to be xlFillDefault (XL at the start, not X1)

Issue with logic when looping in vba

I've created a particularly long vba macro to edit a large spreadsheet of data for me instead of doing it myself thousands of times. The code for the actual editing works fine, however, when I add in the first if statements and first while loop to make it loop through the whole spreadsheet, I get a runtime error 1004. I'm new to vba but I'm pretty sure there is an error in my logic rather than the code itself. I've marked which lines of code cause the error when added.
Sub RCFS()
Dim ProfCtr As String
Dim Year As String
Dim Amount As Currency
Dim Period As Long
Dim S2FreecellH As Long
Dim ProfCenCellH As Long
Dim FreeCellClone As Long
Dim Clone2 As Long
Dim Clone3 As Long
Dim y As Long ' placeholder 2
y = 1
S2FreecellH = 3
ProfCenCellH = 2
AmountH = 2
PeriodH = 2
YearH = 2
ProfCtr = Cells(ProfCenCellH, 4)
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
'//////////////////////////////////////////////////////////////////////////////////
While IsEmpty(Cells(ProfCenCell, 4).Value) = False
Everything fine until this while loop (above) and if statement (below). The rest works fine without these 2 statements but I need it to loop through the whole spreadsheet.
If Cells(ProfCenCell, 4).Value = Worksheets("Sheet2").Cells(S2FreecellH, 1).Value Then
Worksheets("Sheet2").Cells(S2FreecellH, 1).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 5).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 9).Value = ProfCtr
FreeCellClone = S2FreecellH 'setting clones
Clone2 = S2FreecellH
Clone3 = S2FreecellH
For x = S2FreecellH + 1 To S2FreecellH + 12
Worksheets("Sheet2").Cells(x, 2).Value = y 'Creating 1 to 12 numbering in column 1
Worksheets("Sheet2").Cells(x, 6).Value = y 'Creating 1 to 12 numbering in column 2
Worksheets("Sheet2").Cells(x, 10).Value = y 'Creating 1 to 12 numbering in column 3
S2FreecellH = S2FreecellH + 1
y = y + 1
Next x
While Worksheets("Sheet2").Cells(FreeCellClone, 1).Value = Cells(YearH, 4).Value 'Loop to input all amounts
Worksheets("Sheet2").Cells(FreeCellClone + Period, (((Year Mod 11) * 4)) - 1).Value = Amount 'Calculation on post year to select correct column to post amount in
PeriodH = PeriodH + 1
AmountH = AmountH + 1
YearH = YearH + 1
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
Wend
Worksheets("Sheet2").Cells(S2FreecellH + 1, 3) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 3), Worksheets("Sheet2").Cells(S2FreecellH, 3)))
Worksheets("Sheet2").Cells(S2FreecellH + 1, 7) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 7), Worksheets("Sheet2").Cells(S2FreecellH, 7))) 'Creating sums for all 3 columns
Worksheets("Sheet2").Cells(S2FreecellH + 1, 11) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 11), Worksheets("Sheet2").Cells(S2FreecellH, 11)))
For Z = Clone2 + 1 To Clone2 + 12 'creating intitial percentage values
Worksheets("Sheet2").Cells(Z, 4).Value = Format((Worksheets("Sheet2").Cells(Z, 3) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 3)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 8).Value = Format((Worksheets("Sheet2").Cells(Z, 7) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 7)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 12).Value = Format((Worksheets("Sheet2").Cells(Z, 11) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 11)) * 100, "%0.00")
Next
For q = Clone3 + 1 To Clone3 + 12 'creating final percentage values
Worksheets("Sheet2").Cells(q, 13).Value = Format(((Worksheets("Sheet2").Cells(q, 4) + Worksheets("Sheet2").Cells(q, 8) + Worksheets("Sheet2").Cells(q, 12)) / 3) * 100, "%0.00")
Next q
Worksheets("Sheet2").Cells(S2FreecellH + 1, 13) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 13), Worksheets("Sheet2").Cells(S2FreecellH, 13)))
Else
ProfCenCell = ProfCenCell + 1
End If
'/////////////////////////////////////////////////////////////////////////////// Loop these Loops
S2FreecellH = S2FreecellH + 3
y = 1
Wend
End Sub
You never set a value for ProfCenCell, hence it has default value 0. Then, you use Cells(ProfCenCell, 4) which is in your case Cells(0, 4) and that 0 makes a problem.