Excel VBA macro for one column, if true, apply formula to another column - vba

For context:
I would like for the program to look through column B, identify the first "< / >" (which is purely stylistic and can be changed if necessary - it's only used to break up the data) as the start of a week at cell B9 and the next "< / >" (end of the week) at B16. So the range I'm interested in is B10-B15. It would then sum those numbers from J10 to J15 (Earned column) and paste that sum in L16 (Week Total column). The same could then be done with 'Hours' and 'Week Hours'. For the following week (and thereafter) the 'end of the week' "< / >" becomes the start of the week, and the program continues until B200.
I don't have any experience with VBA and so made the following incomplete attempt (based on what I had found online) but felt too out of my depth not to ask for help.
Sub Work()
Dim rng As Range
Dim rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound Is "</>" Then
If Cell = "</>" Then
End If
End Sub
Thank you for any help and please let me know if I can be clearer or elaborate on something.

The following code will loop through 200 lines, looking for your symbol. When found, it will sum the numbers in column J for rows between the current row and the last symbol.
I've included two lines that will update the formula. To me, the 2nd one is easier to understand.
Sub Work()
Dim row As Integer
row = 4
Dim topRowToAdd As Integer 'Remember which row is the
'top of the next sum
topRowToAdd = 4
While row <= 200
If Cells(row, 2) = "</>" Then
'Cells(row, 10).FormulaR1C1 = "=SUM(R[" & -(row - topRowToAdd) & "]C[0]:R[" & -1 & "]C[0])"
Cells(row, 10).Value = "=SUM(J" & topRowToAdd & ":J" & row - 1 & ")"
topRowToAdd = row + 1
End If
row = row + 1
Wend
End Sub

Sub Work()
Dim rng As Range, rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound.Value2 = "</>" Then
'whatever you want to do
End If
End Sub
So at a second glance it looks like this. If you'd like to make it structured you'd need to use a countifs function first.
Sub Work()
Dim rng As Range, rngFound(1) As Range
Set rng = Range("B1:B200")
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
Set rngFound(1) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(0)) 'finds the first after the first (i.e. the second)
Set rngFound(0) = rngFound(0).Offset(1, 8) '8 is the difference between B and J, row shifts as per description, I advise you to make it a variable
Set rngFound(1) = rngFound(1).Offset(-1, 8)
If rngFound(1).Row > rngFound(0).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(1).Offset(1, 2).Formula = "=SUM(" & Range(rngFound(0), rngFound(1)).Address & ")" 'L column will have the sum as a formula
Else
MsgBox "There is a single match in " & rng.Address(False, False)
End If
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub
Now for the grand finale:
Sub Work()
Dim rng As Range, rngFound() As Range, rngdiff(1) As Long, rngcount As Long
Set rng = Range("B1:B200")
rngcount = rng.Cells.Count
ReDim rngFound(rngcount)
rngdiff(0) = Range("J1").Column - rng.Column ' the range that needs to be summed is in column J
rngdiff(1) = Range("L1").Column - rng.Column ' the range containing the formula is in column L
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
'loop starts
For i = 1 To rngcount
Set rngFound(i) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(i - 1)) 'finds the next
If rngFound(i).Row > rngFound(i - 1).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(i).Offset(0, rngdiff(1)).Formula = "=SUM(" & Range(rngFound(i - 1).Offset(1, rngdiff(0)), rngFound(i).Offset(-1, rngdiff(0))).Address & ")" 'L column will have the sum as a formula
Else
Exit Sub 'if it recurred the deed is done
End If
Next i
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub

Related

How to embed a 'lastrow' in a VBA code [duplicate]

How can I find the last row that contains data in a specific column and on a specific sheet?
How about:
Function GetLastRow(strSheet, strColumn) As Long
Dim MyRange As Range
Set MyRange = Worksheets(strSheet).Range(strColumn & "1")
GetLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
End Function
Regarding a comment, this will return the row number of the last cell even when only a single cell in the last row has data:
Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
You should use the .End(xlup) but instead of using 65536 you might want to use:
sheetvar.Rows.Count
That way it works for Excel 2007 which I believe has more than 65536 rows
Simple and quick:
Dim lastRow as long
Range("A1").select
lastRow = Cells.Find("*",SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Example use:
cells(lastRow,1)="Ultima Linha, Last Row. Youpi!!!!"
'or
Range("A" & lastRow).Value = "FIM, THE END"
function LastRowIndex(byval w as worksheet, byval col as variant) as long
dim r as range
set r = application.intersect(w.usedrange, w.columns(col))
if not r is nothing then
set r = r.cells(r.cells.count)
if isempty(r.value) then
LastRowIndex = r.end(xlup).row
else
LastRowIndex = r.row
end if
end if
end function
Usage:
? LastRowIndex(ActiveSheet, 5)
? LastRowIndex(ActiveSheet, "AI")
Public Function LastData(rCol As Range) As Range
Set LastData = rCol.Find("*", rCol.Cells(1), , , , xlPrevious)
End Function
Usage: ?lastdata(activecell.EntireColumn).Address
All the solutions relying on built-in behaviors (like .Find and .End) have limitations that are not well-documented (see my other answer for details).
I needed something that:
Finds the last non-empty cell (i.e. that has any formula or value, even if it's an empty string) in a specific column
Relies on primitives with well-defined behavior
Works reliably with autofilters and user modifications
Runs as fast as possible on 10,000 rows (to be run in a Worksheet_Change handler without feeling sluggish)
...with performance not falling off a cliff with accidental data or formatting put at the very end of the sheet (at ~1M rows)
The solution below:
Uses UsedRange to find the upper bound for the row number (to make the search for the true "last row" fast in the common case where it's close to the end of the used range);
Goes backwards to find the row with data in the given column;
...using VBA arrays to avoid accessing each row individually (in case there are many rows in the UsedRange we need to skip)
(No tests, sorry)
' Returns the 1-based row number of the last row having a non-empty value in the given column (0 if the whole column is empty)
Private Function getLastNonblankRowInColumn(ws As Worksheet, colNo As Integer) As Long
' Force Excel to recalculate the "last cell" (the one you land on after CTRL+END) / "used range"
' and get the index of the row containing the "last cell". This is reasonably fast (~1 ms/10000 rows of a used range)
Dim lastRow As Long: lastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row - 1 ' 0-based
' Since the "last cell" is not necessarily the one we're looking for (it may be in a different column, have some
' formatting applied but no value, etc), we loop backward from the last row towards the top of the sheet).
Dim wholeRng As Range: Set wholeRng = ws.Columns(colNo)
' Since accessing cells one by one is slower than reading a block of cells into a VBA array and looping through the array,
' we process in chunks of increasing size, starting with 1 cell and doubling the size on each iteration, until MAX_CHUNK_SIZE is reached.
' In pathological cases where Excel thinks all the ~1M rows are in the used range, this will take around 100ms.
' Yet in a normal case where one of the few last rows contains the cell we're looking for, we don't read too many cells.
Const MAX_CHUNK_SIZE = 2 ^ 10 ' (using large chunks gives no performance advantage, but uses more memory)
Dim chunkSize As Long: chunkSize = 1
Dim startOffset As Long: startOffset = lastRow + 1 ' 0-based
Do ' Loop invariant: startOffset>=0 and all rows after startOffset are blank (i.e. wholeRng.Rows(i+1) for i>=startOffset)
startOffset = IIf(startOffset - chunkSize >= 0, startOffset - chunkSize, 0)
' Fill `vals(1 To chunkSize, 1 To 1)` with column's rows indexed `[startOffset+1 .. startOffset+chunkSize]` (1-based, inclusive)
Dim chunkRng As Range: Set chunkRng = wholeRng.Resize(chunkSize).Offset(startOffset)
Dim vals() As Variant
If chunkSize > 1 Then
vals = chunkRng.Value2
Else ' reading a 1-cell range requires special handling <http://www.cpearson.com/excel/ArraysAndRanges.aspx>
ReDim vals(1 To 1, 1 To 1)
vals(1, 1) = chunkRng.Value2
End If
Dim i As Long
For i = UBound(vals, 1) To LBound(vals, 1) Step -1
If Not IsEmpty(vals(i, 1)) Then
getLastNonblankRowInColumn = startOffset + i
Exit Function
End If
Next i
If chunkSize < MAX_CHUNK_SIZE Then chunkSize = chunkSize * 2
Loop While startOffset > 0
getLastNonblankRowInColumn = 0
End Function
Here's a solution for finding the last row, last column, or last cell. It addresses the A1 R1C1 Reference Style dilemma for the column it finds. Wish I could give credit, but can't find/remember where I got it from, so "Thanks!" to whoever it was that posted the original code somewhere out there.
Sub Macro1
Sheets("Sheet1").Select
MsgBox "The last row found is: " & Last(1, ActiveSheet.Cells)
MsgBox "The last column (R1C1) found is: " & Last(2, ActiveSheet.Cells)
MsgBox "The last cell found is: " & Last(3, ActiveSheet.Cells)
MsgBox "The last column (A1) found is: " & Last(4, ActiveSheet.Cells)
End Sub
Function Last(choice As Integer, rng As Range)
' 1 = last row
' 2 = last column (R1C1)
' 3 = last cell
' 4 = last column (A1)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Last = Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
Case 4:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Last = R1C1converter("R1C" & Last, 1)
For i = 1 To Len(Last)
s = Mid(Last, i, 1)
If Not s Like "#" Then s1 = s1 & s
Next i
Last = s1
End Select
End Function
Function R1C1converter(Address As String, Optional R1C1_output As Integer, Optional RefCell As Range) As String
'Converts input address to either A1 or R1C1 style reference relative to RefCell
'If R1C1_output is xlR1C1, then result is R1C1 style reference.
'If R1C1_output is xlA1 (or missing), then return A1 style reference.
'If RefCell is missing, then the address is relative to the active cell
'If there is an error in conversion, the function returns the input Address string
Dim x As Variant
If RefCell Is Nothing Then Set RefCell = ActiveCell
If R1C1_output = xlR1C1 Then
x = Application.ConvertFormula(Address, xlA1, xlR1C1, , RefCell) 'Convert A1 to R1C1
Else
x = Application.ConvertFormula(Address, xlR1C1, xlA1, , RefCell) 'Convert R1C1 to A1
End If
If IsError(x) Then
R1C1converter = Address
Else
'If input address is A1 reference and A1 is requested output, then Application.ConvertFormula
'surrounds the address in single quotes.
If Right(x, 1) = "'" Then
R1C1converter = Mid(x, 2, Len(x) - 2)
Else
x = Application.Substitute(x, "$", "")
R1C1converter = x
End If
End If
End Function
I would like to add one more reliable way using UsedRange to find the last used row:
lastRow = Sheet1.UsedRange.Row + Sheet1.UsedRange.Rows.Count - 1
Similarly to find the last used column you can see this
Result in Immediate Window:
?Sheet1.UsedRange.Row+Sheet1.UsedRange.Rows.Count-1
21
Public Function GetLastRow(ByVal SheetName As String) As Integer
Dim sht As Worksheet
Dim FirstUsedRow As Integer 'the first row of UsedRange
Dim UsedRows As Integer ' number of rows used
Set sht = Sheets(SheetName)
''UsedRange.Rows.Count for the empty sheet is 1
UsedRows = sht.UsedRange.Rows.Count
FirstUsedRow = sht.UsedRange.Row
GetLastRow = FirstUsedRow + UsedRows - 1
Set sht = Nothing
End Function
sheet.UsedRange.Rows.Count: retrurn number of rows used, not include empty row above the first row used
if row 1 is empty, and the last used row is 10, UsedRange.Rows.Count will return 9, not 10.
This function calculate the first row number of UsedRange plus number of UsedRange rows.
Last_Row = Range("A1").End(xlDown).Row
Just to verify, let's say you want to print the row number of the last row with the data in cell C1.
Range("C1").Select
Last_Row = Range("A1").End(xlDown).Row
ActiveCell.FormulaR1C1 = Last_Row
get last non-empty row using binary search
returns correct value event though there are hidden values
may returns incorrect value if there are empty cells before last non-empty cells (e.g. row 5 is empty, but row 10 is last non-empty row)
Function getLastRow(col As String, ws As Worksheet) As Long
Dim lastNonEmptyRow As Long
lastNonEmptyRow = 1
Dim lastEmptyRow As Long
lastEmptyRow = ws.Rows.Count + 1
Dim nextTestedRow As Long
Do While (lastEmptyRow - lastNonEmptyRow > 1)
nextTestedRow = Application.WorksheetFunction.Ceiling _
(lastNonEmptyRow + (lastEmptyRow - lastNonEmptyRow) / 2, 1)
If (IsEmpty(ws.Range(col & nextTestedRow))) Then
lastEmptyRow = nextTestedRow
Else
lastNonEmptyRow = nextTestedRow
End If
Loop
getLastRow = lastNonEmptyRow
End Function
Function LastRow(rng As Range) As Long
Dim iRowN As Long
Dim iRowI As Long
Dim iColN As Integer
Dim iColI As Integer
iRowN = 0
iColN = rng.Columns.count
For iColI = 1 To iColN
iRowI = rng.Columns(iColI).Offset(65536 - rng.Row, 0).End(xlUp).Row
If iRowI > iRowN Then iRowN = iRowI
Next
LastRow = iRowN
End Function
Sub test()
MsgBox Worksheets("sheet_name").Range("A65536").End(xlUp).Row
End Sub
This is looking for a value in column A because of "A65536".
The first line moves the cursor to the last non-empty row in the column. The second line prints that columns row.
Selection.End(xlDown).Select
MsgBox(ActiveCell.Row)

Trying to Highlight Used Range of a Column

I'm running into trouble highlighting a column's used range. The following code creates copies of two worksheets, removes some values and then is supposed to highlight certain columns.
Sub CreateAnalysisSheets()
Dim cell, HlghtRng As Range
Dim i As Integer
Dim ref, findLast, findThis As String
Dim lastRow As Long
findLast = "2016"
findThis = "2017"
Application.ScreenUpdating = False
Sheets(1).Copy After:=Sheets(2)
ActiveSheet.Name = Left(Sheets(1).Name, InStr(1, Sheets(1).Name, " ")) & "Analysis"
Sheets(2).Copy After:=Sheets(3)
ActiveSheet.Name = Left(Sheets(2).Name, InStr(1, Sheets(2).Name, " ")) & "Analysis"
Sheets("RM Analysis").Select
For Each cell In ActiveSheet.UsedRange
If cell.Value = "NULL" Then
cell.ClearContents
End If
Next cell
For Each cell In Range("1:1")
ref = cell.Value
lastRow = Range("R" & Rows.Count & "C" & cell.Column).End(xlUp).Row
Set HlghtRng = Range(Cells(1, cell.Column) & Cells(lastRow, cell.Column))
If InStr(1, ref, findLast) > 0 And InStr(1, ref, "YTD") = 0 Then
HlghtRng.Interior.ColorIndex = 8
End If
Next cell
For Each cell In Sheets(4).UsedRange
If cell.Value = "NULL" Then
cell.ClearContents
End If
Next cell
Sheets("RM Analysis").Select
Application.ScreenUpdating = True
End Sub
The problem comes at lastRow = Range("R" & Rows.Count & "C" & cell.Column).End(xlUp).Row where I get an Method 'Range' of Object '_Global' Failed. I've tried searching for ways to fix this issue, but everything I've tried (ActiveSheet.Range and Sheets("RM Analysis").Range) has yet to work.
Anyone see where I'm going wrong here?
The xlR1C1 syntax is fouling up your request for the last non-blank cell.
lastRow = Cells(Rows.Count, cell.Column).End(xlUp).Row
I would highly recommend that you avoid relying on the ActiveSheet and use explicit parent worksheet references. This can be made quite simple using With ... End With and preceding all Range and Cells with a . like .Range(...) or .Cells(...).
Once you within a With ... End With statement, all of the references need to be prefaced with a .. Additionally, the following is not a string concatenation (e.g. &) but as .Range(starting cell comma ending cell) operation.
with worksheets("RM Analysis")
...
Set HlghtRng = .Range(.Cells(1, cell.Column), .Cells(lastRow, cell.Column))
...
end with
this should do
Columns(1).Interior.ColorIndex = 3
change the number of column as to the column you wanna highlit

VBA: adding up irregular ranges

I need some help to create a macro which adds all the values on the column E between the rows with the "avg" word. the result should be displayed on the cells where the "Sum here" label is displayed. Both texts "avg" and "sum here" is just for illustrate the example, "avg" could be replaced by any other word and "sum here" should actually be the aggregation of the values above it.
The real challenge is that the number of ranges on column E is variable, so i would like to find a macro which is able to deal with "n" number of ranges on column E.
Finally, the values on column D are only the example of the expected value on the "sum here" cells.
This is what I have tried to far:
Sub Macro1()
'
' Macro1 Macro
'
Dim sumhere As Range
Dim startingpoint As Range
Dim endingpoint As Range
'
Range("C17").Select
Selection.End(xlDown).Select
If ActiveCell = "avg" Then
ActiveCell.Offset(rowoffset:=0, columnoffset:=2).Select
Set sumhere = ActiveCell
Set startingpoint = ActiveCell.Offset(rowoffset:=-1, columnoffset:=0)
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=sum(range(startingpoint:endingpoint)"
Else
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=Sum(Range(startingpoint.adress:endingpoint.adress))"
Else: End If
End If
End If
End Sub
Additionally, as you can see, I do not know, how to define a range using variables. My original idea was to combine this code with some kind of "do while" or/and "for i= 1 to x" and "next i". But I can't see how to combine it.
Using formula only, and providing that column A only has avg (or any text) on each subtotal row.
I've given two versions of the formula - the volatile version (updates everytime you change anything on the spreadsheet), and the non-volatile version (only updates if it needs to).
The formula should be entered on row 6 - change the $E6 to which ever row you need.
(volatile)
=SUM(OFFSET($E6,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)-ROW()+1,,ROW()-1-IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)))
(non volatile):
=SUM(INDEX($E:$E,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)+1):INDEX($E:$E,ROW()-1))
or if you don't mind using a helper column:
In cell B6:
=IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)
In E6: (volatile)
=SUM(OFFSET($E6,$B6-ROW()+1,,ROW()-1-$B6))
or (non volatile):
=SUM(INDEX($E:$E,$B6):INDEX($E:$E,ROW()-1))
Edit:
Thought I'd add a UDF to calculate it to if you're after VBA.
Use the function =AddSubTotal() in the rows you want the sub total to be shown in, or use =AddSubTotal("pop",6) to sum everything in column F (col 6) using "pop" rather than "avg".
Public Function AddSubTotal(Optional Delim As String = "avg", Optional ColNumber = 5) As Double
Dim rCaller As Range
Dim rPrevious As Range
Dim rSumRange As Range
Set rCaller = Application.Caller
With rCaller.Parent
Set rPrevious = .Range(.Cells(1, 1), .Cells(rCaller.Row - 1, 1)).Find(Delim, , , , , xlPrevious)
If Not rPrevious Is Nothing Then
Set rSumRange = rPrevious.Offset(1, ColNumber - 1).Resize(rCaller.Row - rPrevious.Row - 1)
Else
Set rSumRange = .Range(.Cells(1, ColNumber), .Cells(rCaller.Row - 1, ColNumber))
End If
End With
AddSubTotal = WorksheetFunction.Sum(rSumRange)
End Function
The following VBA routine assumes that
your data is in Columns C:E
Nothing else relevant (nothing numeric) in that range
Your "key word" where you want to show the sum is avg
avg (the key word) is hard-coded in the macro
You could easily modify this routine to also perform an average of those values, and put those results, for example, in Column D
Any of the above are easily modified
Option Explicit
Sub TotalSubRanges()
Dim vSrc As Variant, rSrc As Range
Dim dAdd As Double
Dim I As Long
Const sKey As String = "avg"
Set rSrc = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)).Resize(columnsize:=3)
vSrc = rSrc
'Do the "work" in a VBA array, as this will
' execute much faster than working directly
' on the worksheet
For I = 1 To UBound(vSrc, 1)
If vSrc(I, 1) = sKey Then
vSrc(I, 3) = dAdd
dAdd = 0
Else
If IsNumeric(vSrc(I, 3)) Then dAdd = dAdd + vSrc(I, 3)
End If
Next I
'write the results back to the worksheet
' and conditionally format the "sum" cells
With rSrc
.EntireColumn.Clear
.Value = vSrc
.Columns(3).AutoFit
.EntireColumn.ColumnWidth = .Columns(3).ColumnWidth
.FormatConditions.Delete
.FormatConditions.Add _
Type:=xlExpression, _
Formula1:="=" & .Item(1, 1).Address(False, True) & "=""" & sKey & """"
With .FormatConditions(1)
.Interior.ColorIndex = 6
End With
End With
End Sub
Surely you just need something like:
Sub sums()
Dim i As Integer, j As Integer, k As Integer
j = Range("C1048576").End(xlUp).Row
k = 1
For i = 1 To j
If Range("C" & i).Value <> "" Then
Range("E" & i).Value = "=Sum(E" & k & ":E" & i - 1 & ")"
k = i + 1
End If
Next i
End Sub
Change:
Dim startingpoint As Range
Dim endingpoint As Range
To:
Dim startingpoint As Variant
Dim endingpoint As Variant
As the startingpoint and endingpoint is used in a formula, you cant define them as a Range.

VBA - Set Range Between Two Dates Using Search Function

I'm trying to get my VBA code to search through a column for a user-inputted value (on a form) and set a range based on the values.
I need the code to scan DOWN through the column until it finds the value (which is a date) and then scan UP through the column to get the second part of the range. I need it to be like this because there might be multiple instances of the same date and they all need to be accounted for.
I've tried this:
StartRange = ws.Cells.Find(What:=StartDate, SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues)
EndRange = ws.Cells.Find(What:=EndDate, SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues)
But it's not working the way I had expected and is erroring. (Edit: the WS has been defined, so I know that's not the issue). I don't even know if I'm going about this the right way
I'm feeling defeated :(
Any help would be appreciated, Thanks in advance!
Edit:
I've yet to try any of the suggestions as I am away from my project at the moment, but I feel I need to clarify a few things.
The dates will always be in chronological order, I have a script that organises them on sheet activation
I need to be able to error handle dates that do not appear in the database, I also need the script to be able to "skip over" dates that don't exist. Ie, 1st 1st 1st, 3rd, 3rd, 5th. If my start and end dates were the 1st and 5th, the entire example would be the range.
Thanks for your help so far guys though, I appreciate it!
EDIT2:
I've tried a few answers and have added this in to my code, but it is now failing on a Range_Global fail.
Dim startrange, endrange, searchrange As Range
LookUpColumn = 2
With ws.Columns(LookUpColumn)
Set startrange = .Find(What:=Me.R_Start.Value, _
After:=ws.Cells(.Rows.count, LookUpColumn), _
SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues)
Set endrange = .Find(What:=Me.R_End.Value, _
After:=ws.Cells(5, LookUpColumn), _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues)
searchrange = Range(startrange, endrange)
MsgBox searchrange.Address
End With
Any suggestions?
Using Find is the right way to do this type of thing, you just need to get a few details right.
Use Set to assign range references. Eg Set StartRange = ... (and make sure to Dim StartRange as Range). Ditto EndRange and SearchRange
Specify a After cell. Note that by default this is the Top Left cell of the search range, and the search begins after this cell. If your StartDate happens to be in cell A1 (and another cell) then leaving as default will return the wrong result
Limit the search range to the column of interest.
Dim all your variables. Each variaqble needs its own As (and use Option Explicit)
End result
Dim startrange As Range, endrange As Range, searchrange As Range
Dim LookUpColumn as Long
LookUpColumn = 2
With ws.Columns(LookupColumn)
' Make sure lookup column data is type Date
Set searchrange = .SpecialCells(xlCellTypeConstants)
searchrange.Value = searchrange .Value
Set searchrange = Nothing
Set StartRange = .Find(What:=CDate(StartDate), _
After:=.Cells(.Rows.Count, LookupColumn), _
SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues)
Set EndRange = .Find(What:=CDate(EndDate), _
After:=.Cells(1, LookupColumn), _
SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues)
End With
Set searchrange = Range(startrange, endrange)
MsgBox searchrange.Address
Let's start with this and see what needs to be fine tuned.
This code will look for a date (based on input) and find the position of that date in a column. Same with the "EndDate" and then creates a range on that column between the 2 positions.
Sub ARange()
Dim Sh As Worksheet: Set Sh = Sheets("Sheet1")
Dim i, j As Integer
LookupColumn = "A" 'Define the LookupColum / If you find using column index to be simpler then you need to switch the search from (range) to (cells)
StartDate_Value = Sh.Range("B2").Value 'Use whatever you need to define the input values
EndDate_Value = Sh.Range("C2").Value 'Use whatever you need to define the input values
For i = 1 To 30000
If Sh.Range(LookupColumn & i).Value = EndDate_Value Then EndDate_Row = i
Next i
For j = EndDate_Row To 1 Step -1
If Sh.Range(LookupColumn & j).Value = StartDate_Value Then StartDate_Row = j
Next j
Dim MyDateRange As Range: Set MyDateRange = Sh.Range(LookupColumn & StartDate_Row & ":" & LookupColumn & EndDate_Row)
MsgBox "MyDateRange = " & LookupColumn & StartDate_Row & ":" & LookupColumn & EndDate_Row
End Sub
Another approach should imply looking for the EndDate from bottom upwards (as in Excel's column values) and for the StartDate from top to bottom. like this:
For i = 30000 to 1 step -1
For j = 1 To 30000
And the 3rd (the charm):for the EndDate from top to bottom and for the StartDate from top to bottom. like this:
For i = 1 to 30000
For j = 1 To 30000
And the 4th (The One):
For i = 1 to 30000
For j = 30000 to 1 Step -1
On my home laptop the search on the 30.000 cells is instant (under 1s).
Give it a try and based on the feedback we can fine tune it.
On the Other hand, I might read your question as for looking To select not all values between the top / bottom position, but any cells with values of dates between the 2 input values neverminind the arrangement of the values within the list (column cells). i.e. If StartDate = 1.Jan.2013 and EndDate = 3.Jan.2013. The code should pick up 1,2 and 3 from the 30.000 list neverminind the position of these 3 dates (which in fact may be found thousands of times). If This is true, the solution may be simpler than the one above.
I don't like the concept of this date search for a couple of reasons..
It makes the assumption that the dates will always be in order
It makes the assumption that both the dates will exist in the list
Whilst these may be valid assumptions in this case, I'm sure there may be instances where this may not be the case...
I don't know the best way to do this but one alternative to consider is using the auto-filter
Something like:
Sub FindDateRange()
Dim sht As Worksheet
Dim column As Long
Set sht = Sheet1
Dim rng As Range, inclusiveRange As Range
Dim startDate As Long, endDate As Long
column = 2
On Error GoTo Err
startDate = DateValue("02/10/2012")
endDate = DateValue("05/10/2012")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sht.Cells(1, column).AutoFilter Field:=column, Criteria1:=">=" & startDate, Operator:=xlAnd _
, Criteria2:="<=" & endDate
Set rng = sht.Range(sht.Cells(2, column), sht.Cells(sht.Cells(sht.Rows.Count, column).End(xlUp).Row, column)).SpecialCells(xlCellTypeVisible)
sht.AutoFilterMode = False
If rng.Address = sht.Cells(1, column).Address Then
MsgBox Format(startDate, "dd-mmm-yyyy") & " - " & Format(endDate, "dd-mmm-yyyy") _
& vbCrLf & vbCrLf & "No instances of the date range exist"
Else
Set inclusiveRange = sht.Range(rng.Cells(1, 1), rng.Cells(rng.Count, 1))
MsgBox Format(startDate, "dd-mmm-yyyy") & " - " & Format(endDate, "dd-mmm-yyyy") _
& vbCrLf & vbCrLf & "the range is " & rng.Address & vbCrLf & vbCrLf & _
"inclusive range is " & inclusiveRange.Address
End If
continue:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
Err:
MsgBox Err.Description
GoTo continue
End Sub

Next Without For error in nested loop in Excel VBA

I am trying to figure out a way to run a Vlookup on a Cell in my "System File" by checking a table in a "New Data" File. HOWEVER, if there is an #N/A error, I want the cells' values to be unchanged. I've come up with the following, however, I keep getting a "Next without For" error. Is it possible to escape a nested For Next loop?
The tl;dr semantic version:
For i 1 to 10
For j 1 to 3
Something with .Cells(i,j)
Set range X = .Find(thing
If X = Nothing Then
Next j *** <THIS IS WHERE MY ERROR IS THROWN
Else
-Do Something with X-
End if
Next j
Next i
My more or less actual code is as follows:
Sub Thing()
Dim SysWS As Worksheet
Dim NewDataWS As Worksheet
Dim NDSKUs As Range ' This is set to the first column of the NewDataWS
Dim NDMonthsRow As Range ' This is set to the first row of the NewDataWS
Dim SKU2look4 As String, Month2look4 As String
Dim ifoundtheSKU As Range 'the result of finding SKU2look4 inside of NDSKUs range
Dim ifoundtheDate As Range 'the result of finding Month2look4 inside of NDMonthsRow range
Dim i As Integer, j As Integer
Dim workzone As Range 'The Cell being evaluated
For i = 2 To SysWS.UsedRange.Columns.Count
For j = 2 To SysWS.UsedRange.Rows.Count
Set workzone = SysWS.Cells(j, i)
SKU2look4 = SysWS.Cells(j, 1) 'SKUs are along the left column
Month2look4 = SysWS.Cells(1, i) 'Dates are along the top row
'1-Find the right Date Column for extraction
Set ifoundtheDate = NDMonthsRow.Find(What:=Month2look4, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If ifoundtheDate Is Nothing Then
Debug.Print (Month2look4 & " -Date NOT Found in New Date File")
******Next j******
Else
Debug.Print ("ifoundtheDate:" & ifoundtheDate.Address)
End If
'2-Find the row
Set ifoundtheSKU = NDSKUs.Find(What:=SKU2look4, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If ifoundtheSKU Is Nothing Then
Debug.Print (SKU2look4 & " Not Found in the New Data File")
*********Next j******
Else
Debug.Print ("ifoundtheSKU:" & ifoundtheSKU.Address)
End If
'Set the "workzone" cell's value to that of the found row offset by the found column
workzone = ifoundtheSKU.Offset(, (ifoundtheDate.Column - 1))
Next j
Next i
Of course the ***s are not actually in there. Any thoughts on how I can accomplish this?
Thanks in advance
For i = 1 to 10
For j = 1 to 3
Something with .Cells(i,j)
Set rngX = .Find(thing)
If Not rngX Is Nothing Then
Set rngY = .Find(thingelse)
If Not rngY Is Nothing Then
'something with rngX and rngY
End If
End if
Next j
Next i
Use
For i=1 to 10
For j=1 to 3
Something with .Cells(i,j)
Set range X = .Find(thing
If X = Nothing Then
Goto Nextj *** <THIS IS WHERE MY ERROR IS THROWN
Else
-Do Something with X-
End if
NextJ:
Next j
Next i
Exit For terminates the current for loop early (the inner one in your case).