Scheduled VBA task and 'Application.OnTime' - vba

I have the following VBA code which is working well. It's calling another VBA Sub without any trouble:
Public Sub AutoPrintMissingHistoric()
Dim qdf As DAO.QueryDef
Dim rcs As DAO.Recordset
Dim db As DAO.Database
Dim j As Integer
Dim flag As Boolean
Dim i As Long
Dim value_start, value_end As String
Dim tmp As Date
Dim wbRiskedge As Workbook
Dim wsAccueil As Worksheet
Dim wsHistoric As Worksheet
Set wbRiskedge = Workbooks(StrWbRiskedge)
Set wsAccueil = wbRiskedge.Worksheets(StrWsAccueil)
Set wsHistoric = wbRiskedge.Worksheets(StrWsHistoricMissing)
If FistTime = True Then
Call Initialisation.CleanTab
Else
FistTime = True
Call Initialisation.Initialisation
End If
vDelay = 5
Cpt = Cpt + 1
Set db = DBEngine.OpenDatabase(strDB)
Set qdf = db.QueryDefs("Get_missing_fixings")
If Cpt <= wsAccueil.Range(ManualListLetter & "1").End(xlDown).Row Then
Application.StatusBar = wsAccueil.Cells(Cpt, ManualListLetter).Text
qdf.Parameters("arg1") = wsAccueil.Cells(Cpt, ManualListLetter).Value
Set rcs = qdf.OpenRecordset
j = 0
i = 1
flag = False
If Not rcs.EOF Then
rcs.MoveLast
rcs.MoveFirst
While Not rcs.EOF
j = 0
While j < rcs.Fields.Count
If flag = False Then
With Cells(i, j + 1)
If .Value = "" Then
.Value = rcs(j).Name
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End If
End With
Else
Cells(i, j + 1).Value = rcs(j).Value
End If
j = j + 1
Wend
If flag = False Then
flag = True
End If
i = i + 1
rcs.MoveNext
Wend
Call ChangeMinMax(rcs.RecordCount, CellMinDate, CellMaxDate, wsHistoric)
Call ParseParameters
Call SetReutersFunction
End If
rcs.Close
qdf.Close
db.Close
wsHistoric.Calculate
Application.StatusBar = wsAccueil.Cells(Cpt, ManualListLetter).Text & " - Next Function: FindMissingValue.AutoFindMissingValue"
sToCall = "FindMissingValue.AutoFindMissingValue"
MTimeGT = Time + TimeValue("00:00:" & vDelay)
Application.OnTime MTimeGT, sToCall
End If
End Sub
I put the execution of this process in a scheduled task. But apparently my code is not well executed: the FindMissingValue.AutoFindMissingValue Sub is not called because Excel just closes.
I think it's because of Application.OnTime MTimeGT, sToCall... What could be the reason?
Here you've the code of FindMissingValue.AutoFindMissingValue
Sub AutoFindMissingValue()
Dim wbRiskedge As Workbook
Dim wsAccueil As Worksheet
Dim wsHistoric As Worksheet
Dim i, nbResult As Long
Set wbRiskedge = Workbooks(StrWbRiskedge)
Set wsAccueil = wbRiskedge.Worksheets(StrWsAccueil)
Set wsHistoric = wbRiskedge.Worksheets(StrWsHistoricMissing)
If Left(wsHistoric.Range(ReutersFormula).Text, 13) Like "Retrieving...*" = True Then
sToCall = "FindMissingValue.AutoFindMissingValue"
MTimeGT = Time + TimeValue("00:00:05")
Application.OnTime MTimeGT, sToCall
Exit Sub
End If
i = WorksheetFunction.CountA(Columns(DateColumn & ":" & DateColumn))
If WorksheetFunction.CountA(Columns(ColumnResearchVResult & ":" & ColumnResearchVResult)) > 0 Then
wsHistoric.Range(FirstCellResearchVResult & ":" & ColumnResearchVResult & WorksheetFunction.CountA(Columns(ColumnResearchVResult & ":" & ColumnResearchVResult))).ClearContents
End If
nbResult = wsHistoric.Range(FirstResult).End(xlDown).Row
wsHistoric.Range(ColumnResearchVResult & LineResearchVResult - 1).Value = "Results"
If WorksheetFunction.CountA(Columns(DateColumn & ":" & DateColumn)) > 1 Then
wsHistoric.Range(FirstCellResearchVResult & ":" & ColumnResearchVResult & i).FormulaLocal = "=RECHERCHEV($" & DateColumn & "$" & LineResearchVResult & ":$" & DateColumn & "$" & i & ";" & FirstLockResult & ":$" & ValueResultColumn & "$" & nbResult & ";2;0)"
End If
Application.StatusBar = wsAccueil.Cells(Cpt, ManualListLetter).Text & " - Next Function: FindMissingValue.AutoPutResultInDb"
sToCall = "FindMissingValue.AutoPutResultInDb"
MTimeGT = Time + TimeValue("00:00:01")
Application.OnTime MTimeGT, sToCall
End Sub

The Application.OnTime part is right and FindMissingValue.AutoFindMissingValue should be called without any problem (after 5 seconds). What might happen is that, during this 5 seconds period, the code continues running, goes back to where AutoPrintMissingHistoric was called from, and the workbook might be closed before these 5 seconds have passed (although, depending upon your exact conditions, the function should be called even despite the workbook is closed).
You can either reduce the waiting period (vDelay = 1, for example) or just call the function directly (Call FindMissingValue.AutoFindMissingValue). Actually, I am not sure why you are calling the function by relying on Application.OnTime; using this is fine for "starting the process" (e.g., "I want my macro to be executed every day at 00:00"), but might drive to "messy situations" in case of being used on a regular basis.
If nothing of this works, please, provide the code of FindMissingValue.AutoFindMissingValue to take a look at it.
NOTE: after some further tests/discussions, I can confirm that the behavior of OnTime under these specific conditions is "too irregular". You should come up with a different approach to allow the waiting period you need or, in case of having to rely on OnTime, do an intensive trial-and-error to make sure that its behaviour is completely under control. This function is expected to be called once (opening the spreadsheet at certain time, for example) and thus you have to pay lots of attention when using it on different contexts (like this one: calling it inside a function).

Related

Apply vba to multiple cells

I have a code that can generate page number on cells.
But I want it apply to mutiple cells in one time instead of single cells.
Sub pagenumber()
'updateby Extendoffice 20160506
Dim xVPC As Integer
Dim xHPC As Integer
Dim xVPB As VPageBreak
Dim xHPB As HPageBreak
Dim xNumPage As Integer
xHPC = 1
xVPC = 1
If ActiveSheet.PageSetup.Order = xlDownThenOver Then
xHPC = ActiveSheet.HPageBreaks.Count + 1
Else
xVPC = ActiveSheet.VPageBreaks.Count + 1
End If
xNumPage = 1
For Each xVPB In ActiveSheet.VPageBreaks
If xVPB.Location.Column > ActiveCell.Column Then Exit For
xNumPage = xNumPage + xHPC
Next
For Each xHPB In ActiveSheet.HPageBreaks
If xHPB.Location.Row > ActiveCell.Row Then Exit For
xNumPage = xNumPage + xVPC
Next
ActiveCell = "Page " & xNumPage & " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
End Sub
What can i do for this? Is it also possible for apply the code to highlighted cells?
At the end write this:
Range("A1:B10")="Page "&xNumPage&" of "& Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Instead of:
ActiveCell = "Page "&xNumPage& " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Making sure that Range("A1:B10") is the range to which you want to apply the numbers.
How to avoid using Select in Excel VBA

Excel VBA InStr very slow and hanging

I am using the below VBA code to compare 60K records (only a particular string) from 'Sheet1' with 7K records from 'Sheet2'. It's taking a very long time to complete and is unresponsive at times. Is there anyway to improve the performance of this subroutine?
Sub txtext()
Dim fnl As String, stl As String, env As String, typ As String
Dim ctm As String
Dim stdate As Date, enddate As Date
lr = Sheets("cid_match").Range("A" & Rows.Count).End(xlUp).Row
cr = Sheets("scme").Range("C" & Rows.Count).End(xlUp).Row
stdate = Now
m = 2
For Each e In Sheets("cid_match").Range("BI2:BI" & lr).Cells
stl = Worksheets("cid_match").Range("BI" & m).Cells.Value
typ = Worksheets("cid_match").Range("BK" & m).Cells.Value
s = 2
For Each r In Sheets("scme").Range("C2:C" & cr).Cells
ctm = Worksheets("scme").Range("B" & s).Cells.Value
fnl = r.Value
If InStr(fnl, stl) > 0 And ctm = typ Then
Worksheets("cid_match").Range("BJ" & m).Value = fnl
GoTo sss
End If
s = s + 1
Next r
sss:
m = m + 1
Next e
enddate = Now
MsgBox "Succesfully Completed!!! Started at " & stdate & " Ended at " & enddate
End Sub
In order to optimize searching for a record you want to firstly sort your data using either quicksort or bubblesort. Then you will be able to search through using binary search. This will significantly reduce your wait times. Lucky you, these functions have already been written in VBA by other developers.
Bubblesort
Sub BubbleSort(list())
' Sorts an array using bubble sort algorithm
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim Temp As Long
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
Temp = list(j)
list(j) = list(i)
list(i) = Temp
End If
Next j
Next i
End Sub
Binary Search
Function arrayFind(theArray() As Integer, target As Integer) As Boolean
Dim low As Integer
low = 0
Dim high As Integer
high = UBound(theArray)
Dim i As Integer
Dim result As Boolean
Do While low <= high
i = (low + high) / 2
If target = theArray(i) Then
arrayFind = True
Exit Do
ElseIf target < theArray(i) Then
high = (i - 1)
Else
low = (i + 1)
End If
Loop
If Not arrayFind Then
arrayFind = False
End If
End Function
Try the below: -
Sub Sample()
Dim AryLookup() As String
Dim DteStart As Date
Dim LngCounter As Long
Dim LngRow As Long
Dim WkSht As Worksheet
DteStart = Now
'Look at the lookup worksheet
Set WkSht = ThisWorkbook.Worksheets("scme")
'Make an array the same size as the dataset
ReDim AryLookup(WkSht.Range("C" & Rows.Count).End(xlUp).Row)
'Copy the dataset in
For LngRow = 2 To UBound(AryLookup, 1)
AryLookup(LngRow - 2) = WkSht.Range("C" & LngRow)
DoEvents
Next
Set WkSht = Nothing
'Look at the source worksheet
Set WkSht = ThisWorkbook.Worksheets("cid_match")
'Work from the bottom up so not to be falsly stopped by an empty row
'Step -1 means go backwards by one with each itteration of the loop
For LngRow = WkSht.Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
'Look through the loop for a match
For LngCounter = 0 To UBound(AryLookup, 1)
'If it matches then add it to the column and exit the loop
If InStr(1, WkSht.Range("BI" & LngRow), AryLookup(LngCounter)) > 0 Then
WkSht.Range("BJ" & LngRow).Value = AryLookup(LngCounter)
Exit For
End If
DoEvents
Next
DoEvents
Next
Set WkSht = Nothing
MsgBox "Succesfully Completed!!! " & vbNewLine & "Started at " & DteStart & vbNewLine & "Ended at " & Now
End Sub
Looking over your code was quite confusing to follow what was happening, in some cases I couldn't understand or see the benefit in what was happening in the code, so the above may not be correct. You should always write your code with the assumption that another developer will need to pick it up and support it one day, it'll help you in the future if you have to return to it years later and want to remember what is happening.

Stop intensive file process?

I'm using the following function to read files into a spreadsheet. I was thinking of adding a stop button (something like this) but the problem is that while this is running it completely locks up Excel and I cannot interact with it in any way. Is there a way to gracefully stop something like this? Note that these are huge files (500,000+ lines)
Function LoadFile(m)
Dim WrdArray() As String
Dim txtstrm As TextStream
Dim line As String
Dim clm As Long
Dim Rw As Long
Dim Dash As Worksheet
Set Dash = Sheets("Dashboard")
Set cellStatus = Dash.Range("E3")
Set txtstrm = FSO.OpenTextFile("s:\views_" & m & ".txt")
Rw = 1
Do Until txtstrm.AtEndOfStream
If Rw Mod 4 = 0 Then cellStatus.Value = "Loading " & m & "... /"
If Rw Mod 4 = 1 Then cellStatus.Value = "Loading " & m & "... |"
If Rw Mod 4 = 2 Then cellStatus.Value = "Loading " & m & "... \"
If Rw Mod 4 = 3 Then cellStatus.Value = "Loading " & m & "... -"
line = txtstrm.ReadLine
clm = 1
WrdArray() = Split(line, "|!|")
For Each wrd In WrdArray()
Sheets(m).Cells(Rw, clm) = wrd
clm = clm + 1
Next wrd
Rw = Rw + 1
Loop
txtstrm.Close
LoadFile = Rw
End Function
First, turn off screen refreshing and calculation.
Application.ScreenUpdating = False
Application.Calculation = xlManual
then at the very end, turn back on
Application.ScreenUpdating = True
Application.Calculation = XlCalculationAutomatic
Additonally, if you add some type of counter that, after X iterations, prompts the user to continue or not, something like
Dim myCount as Long
...your loop starts here
myCount = myCount + 1
If myCount mod 1000 = 0 then
toContinue = msgBox("Continue with macro?",vbYesNo)
If toContinue = vbNo then exit sub
End if
...continue loop
Edit: Bah, I'll have to tweak that If myCount mod 1000 = 0 to something better...basically an even divisor of 1000 or something.
Also, is the loading "animation" required? I bet that contributes to it taking long when running over that many cells. And, just thought of it, when you turn off screenupdating, you won't see that animation, so maybe comment it out and see how it runs.
In order for excel not to 'lock up' you have to call 'DoEvents'. Using the following will also speed up your process, however it appears as though you'll need screen updating to update the status bar, and EnableEvents to operate your button press event.
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
You can use the application's status bar at the very bottom if you want by doing the following:
Application.StatusBar = "Your Value Here"
Just make sure to clear it before you leave your function. If you wanted to be really 'safe' you can store its old previous value before writing to it then restore it here.
Application.StatusBar = ""
Your modified code is below:
Function LoadFile(m)
Dim WrdArray() As String
Dim txtstrm As TextStream
Dim line As String
Dim clm As Long
Dim Rw As Long
Dim Dash As Worksheet
Application.Calculation = xlManual
Set Dash = Sheets("Dashboard")
Set cellStatus = Dash.Range("E3")
Set txtstrm = FSO.OpenTextFile("s:\views_" & m & ".txt")
Rw = 1
Do Until txtstrm.AtEndOfStream
If Rw Mod 4 = 0 Then Application.StatusBar = "Loading " & m & "... /"
If Rw Mod 4 = 1 Then Application.StatusBar = "Loading " & m & "... |"
If Rw Mod 4 = 2 Then Application.StatusBar = "Loading " & m & "... \"
If Rw Mod 4 = 3 Then Application.StatusBar = "Loading " & m & "... -"
line = txtstrm.ReadLine
clm = 1
WrdArray() = Split(line, "|!|")
For Each wrd In WrdArray()
Sheets(m).Cells(Rw, clm) = wrd
clm = clm + 1
Next wrd
Rw = Rw + 1
'This will insure that excel doesn't lock up or freeze
DoEvents
Loop
txtstrm.Close
LoadFile = Rw
Application.Calculation = XlCalculationAutomatic
Application.StatusBar = ""
End Function
Not sure why you do this in a Function, but if you have Sub that calls this, it may be better to pause calculation there.
Anyway, try this (dumping array values in one go):
Function LoadFile(m)
Dim WrdArray() As String
Dim txtstrm As Object
Dim line As String
Dim clm As Long ' Now used as number of items in the Split
Dim CalcMode As Long
Dim Rw As Long
Dim Dash As Worksheet
Set Dash = Sheets("Dashboard")
'Set cellStatus = Dash.Range("E3")
Set txtstrm = FSO.OpenTextFile("s:\views_" & m & ".txt")
Rw = 1
CalcMode = Application.Calculation ' Save calculation mode
Application.Calculation = xlCalculationManual ' Change to Manual Calculation
Do Until txtstrm.AtEndOfStream
Application.StatusBar = Now & ": Loading " & m & " (Rw: " & Rw & ")"
'If Rw Mod 4 = 0 Then cellStatus.Value = "Loading " & m & "... /"
'If Rw Mod 4 = 1 Then cellStatus.Value = "Loading " & m & "... |"
'If Rw Mod 4 = 2 Then cellStatus.Value = "Loading " & m & "... \"
'If Rw Mod 4 = 3 Then cellStatus.Value = "Loading " & m & "... -"
line = txtstrm.ReadLine
'clm = 1
WrdArray = Split(line, "|!|")
clm = UBound(WrdArray) + 1 ' Number of items in the split
' Dump the array to cells value to resized range from Col A
Sheets(m).Cells(Rw, "A").Resize(, clm).Value = WrdArray
'For Each wrd In WrdArray()
' Sheets(m).Cells(Rw, clm) = wrd
' clm = clm + 1
'Next wrd
Rw = Rw + 1
Loop
txtstrm.Close
Application.StatusBar = False ' Reset status bar
Application.Calculation = CalcMode ' restore calculation mode
LoadFile = Rw
End Function

Loop to go through a list of values

I currently have a macro which goes through a column on my master spreadsheet, then exports all the rows where the value input at the start matches the value in the column. It then saves the new worksheet as the value. Here is the code I currently have:
Option Explicit
Public Const l_HeaderRow As Long = 2 'The header row of the data sheet
Public Const l_DistanceCol As Long = 5 'The column containing the distance values
Public Sub ExportDistance()
Dim ws_Data As Worksheet, wb_Export As Workbook, ws_Export As Worksheet
Dim l_InputRow As Long, l_OutputRow As Long
Dim l_LastCol As Long
Dim l_NumberOfMatches As Long
Dim s_Distance As String, l_Distance As Long
Dim s_ExportPath As String, s_ExportFile As String, s_PathDelimiter As String
Set ws_Data = ActiveSheet
s_Distance = InputBox("Enter Distance to Export to New File", "Enter Distance")
If s_Distance = "" Then Exit Sub
l_Distance = CLng(s_Distance)
l_NumberOfMatches = WorksheetFunction.Match(l_Distance, ws_Data.Columns(5), 0)
If l_NumberOfMatches <= 0 Then Exit Sub
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error Resume Next
Call Application.Workbooks.Add
Set wb_Export = Application.Workbooks(Application.Workbooks.Count)
Set ws_Export = wb_Export.Worksheets(1)
Call wb_Export.Worksheets("Sheet2").Delete
Call wb_Export.Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
ws_Export.Name = GetNextSheetname(ws_Data.Name & "-" & s_Distance, wb_Export)
Call ws_Data.Rows(1).Resize(l_HeaderRow).Copy
Call ws_Export.Rows(1).Resize(l_HeaderRow).Select
Call ws_Export.Paste
l_OutputRow = l_HeaderRow + 1
l_LastCol = ws_Data.UsedRange.Columns.Count
For l_InputRow = l_HeaderRow + 1 To ws_Data.UsedRange.Rows.Count
If ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
ElseIf ws_Data.Cells(l_InputRow, l_DistanceCol).Value = l_Distance Then
Call ws_Data.Range(ws_Data.Cells(l_InputRow, 1), ws_Data.Cells(l_InputRow, l_LastCol)).Copy
Call ws_Export.Rows(l_OutputRow).Select
Call ws_Export.Paste
l_OutputRow = l_OutputRow + 1
End If
Next l_InputRow
s_ExportPath = ThisWorkbook.Path
s_PathDelimiter = Application.PathSeparator
If Right(s_ExportPath, 1) <> s_PathDelimiter Then s_ExportPath = s_ExportPath & s_PathDelimiter
s_ExportPath = s_ExportPath & "Output" & s_PathDelimiter
If Dir(s_ExportPath) = Empty Then
Call MkDir(s_ExportPath)
End If
Select Case Application.DefaultSaveFormat
Case xlOpenXMLWorkbook
s_ExportFile = s_Distance & ".xlsx"
Case xlOpenXMLWorkbookMacroEnabled
s_ExportFile = s_Distance & ".xlsm"
Case xlExcel12
s_ExportFile = s_Distance & ".xlsb"
Case xlExcel8
s_ExportFile = s_Distance & ".xls"
Case xlCSV
s_ExportFile = s_Distance & ".csv"
Case Else
s_ExportFile = s_Distance
End Select
Call wb_Export.SaveAs(Filename:=s_ExportPath & s_ExportFile, FileFormat:=Application.DefaultSaveFormat)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Function GetNextSheetname(s_Name As String, Optional wb_Book As Workbook) As String
Dim l_FIndex As Long
Dim s_Target As String
If wb_Book Is Nothing Then Set wb_Book = ActiveWorkbook
s_Name = Left(s_Name, 31)
If IsValidSheet(wb_Book, s_Name) Then
l_FIndex = 1
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
Do While IsValidSheet(wb_Book, s_Target)
l_FIndex = l_FIndex + 1
If l_FIndex < 10 Then
s_Target = Left(s_Name, 27) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 100 Then
s_Target = Left(s_Name, 26) & " (" & l_FIndex & ")"
ElseIf l_FIndex < 1000 Then
s_Target = Left(s_Name, 25) & " (" & l_FIndex & ")"
End If
Loop
GetNextSheetname = s_Target
Else
GetNextSheetname = s_Name
End If
End Function
Public Function IsValidSheet(wbSearchBook As Workbook, v_TestIndex As Variant) As Boolean
Dim v_Index As Variant
On Error GoTo ExitLine
v_Index = wbSearchBook.Worksheets(v_TestIndex).Name
IsValidSheet = True
Exit Function
ExitLine:
IsValidSheet = False
End Function
Please will you help me make this loop through a list of values, rather than my having manually to run the macro each time and input the value myself?
Download this example here.
This is a simple example of how to loop through one range and loop through another range to find the values.
It loops through Column D and then loops through column A, when it finds a match it does something, so basically Column D has taken the place of your inputbox.
run the macro
The code
Sub DblLoop()
Dim aLp As Range 'column A
Dim dLp As Range, dRw As Long 'column D
Dim d As Range, a As Range
Set aLp = Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
dRw = Cells(Rows.Count, "D").End(xlUp).Row
Set dLp = Range("D2:D" & dRw)
'start the loop
'loops through column D and finds value
'in column A, and does something with it
For Each d In dLp.Cells 'loops through column D
For Each a In aLp.Cells 'loops through column A
If d = a Then
'When a match, then do something
'this is where your actual code would go
Range("A" & a.Row & ":B" & a.Row).Copy Cells(Rows.Count, "F").End(xlUp).Offset(1)
End If
Next a 'keeps going through column A
Next d 'next item in column D
End Sub

VBA another for-loop question

I know there are a ton of questions about constructing looped codes in vBA already but hopefully this will be a quick answer, i wasn't able to find a page addressing this issue.
My goal is to check the values from one range with values in another range, and if is a match it will perform a function and display results at the end. However, if the corresponding value in the range is "N/A" I want the results to display immediately and move onto the next checked value. Right now I am obtaining a 'no for loop' error for my code and i understand why. But I don't know how to fix this problem. Can anyone help?
Sub solubility()
Dim coeff As Range, groups As Range
Dim anion As Range
Dim a As Range
Dim nextrow As Long
Dim j As Range
Worksheets("properties").Select
Range("P7:P2000").Select
Selection.ClearContents
'solubility groups range
groups = Worksheets("Solubility").Range("A2:A33")
'group coefficients range
coeff = Worksheets("Solubility").Range("B2:B33")
anion = Worksheets("properties").Range("AB7:AB887")
For Each a In anion
For Each j In groups
If UCase(a.Value) = UCase(groups(j).Value) Then
If groups(j).Value = "" Or "N/A" Then
Worksheets("properties").Range("P" & a.Row).Value = "N/A"
Next a
Else
anvalue = coeff(j).Value * Range("AC" & a.Row).Value
End If
End If
If UCase(Range("AD" & a.Row).Value) = UCase(groups(j).Value) Then
cavalue = coeff(j).Value * Worksheets("properties").Range("AE" & a.Row).Value
If UCase(Range("AF" & a.Row).Value) = UCase(groups(j).Value) Then
cb1value = coeff(j).Value * Worksheets("properties").Range("AG" & a.Row).Value
End If
If UCase(Range("AH" & a.Row).Value) = UCase(groups(j).Value) Then
cb2value = coeff(j).Value * Worksheets("properties").Range("AI" & a.Row).Value
End If
Next j
If UCase(Range("AD" & a.Row).Value) = UCase("[MIm]") Then
cavalue = Range("AE" & a.Row) * Worksheets("solubility").Range("B2").Value + Range("AE" & a.Row) * Worksheets("solubility").Range("B7").Value
End If
nextrow = Worksheets("properties").Cells(Rows.Count, 15).End(xlUp).Offset(1, 0).Row
Worksheets("properties").Range("P" & nextrow).Value = _
anvalue + cavalue + cb1value + cb2value + Worksheets("solubility").Range("b34").Value
Next a
End Sub
I have the line 'Next a' twice, and excel doesnt like this, but I want to automatically jump to the next checked value without performing the remaining function if I get the "N/A" value.
I know this will rile the feathers of some of my purist brethren, but I would actually suggest a judicious use of GoTo in your case:
For Each a In anion
For Each j In groups
If UCase(a.Value) = UCase(groups(j).Value) Then
If groups(j).Value = "" Or "N/A" Then
Worksheets("properties").Range("P" & a.Row).Value = "N/A"
GoTo NextA
....
End If
End If
....
Next j
....
NextA:
Next a
Overuse of GoTo will quickly turn your code into spaghetti, but in this case I think it is actually the most readable option you have.
You must define a reference to an object using SET:
SET groups = Worksheets("Solubility").Range("A2:A33")
(Same for all ranges)