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.