How to loop indices of .formula/.formulaR1C1 - excel

I am stuck with a problem i cannot get my head around currently.
I have a checklist that has to update automatically when adding lines to my excel worksheet so that the checklist is applied to all rows.
I tried to use a "for loop" to modify the formula but excel returns Error 1004, when starting the string with "=".
No error but no functionality as well:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "Wenn(Oder(AB" & firstRow & "=""x"""
Returns error 1004:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "=Wenn(Oder(AB" & firstRow & "=""x"""
My first solution
Loop FormulaR1C1, or Formula and use nothing but english Function names eg. sum() instead of Summe() and follow english syntax , instead of ;.
Problem
When testing the syntax without a loop and actual indices it works like a charm. As soon as I try to loop it, Excel does not recognize R[i]C as cell anymore but just returns plain text.
no issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[1]C = ""x"""
issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[i]C = ""x"""
Splitting it like this did not solve my problem either
..R[" & i & "]C =..
Any tips?
// For i= ... to .. next i
// Excel 2007

Try this:
With ActiveWorkbook.Sheets("Kalkulation Änderungen")
'find last row of column AB
LastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
'apply the formula from AB9 to its last non-blank row
.Range("AB9:AB" & LastRow).Formula = "IF(OR( R[1]C = ""x"""
End With

#UGP: that is what i thought the code might look like after implementing your tips with intersect etc.
What do you think of it, I guess you might not like the loops too much?
Typical beginner approach to loop everything?
I would have to do this for every column accordingly?
If so it would be wise to create a sub () for every column with an exit condition so that i save computing time?
Unless it is possible to hand over the columnadress to the sub_worksheet_change()?
Private Sub Worksheet_Change(ByVal Target As Range, selected_column)
_
_
_
_
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim check As Boolean
frstRow = 1
lastRow = 1
i = 1
'Rowcount
Do Until firstRow <> 1 And lastRow <> 1
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("D" & i) = "Länge" Then
firstRow = i + 2
i = i + 1
End If
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("G" & i) = "Gesamt-h" Then
lastRow = i - 2
End If
i = i + 1
Loop
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & firstRow, "AI" & lastRow)
check = False
i = firstRow
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Do While i <= lastRow And check = False
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB" & i).Value = "x" Then
check = True
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = "x"
ElseIf i = lastRow And check = False Then
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = " "
End If
i = i + 1
Loop
End If
End Sub

Here's the code. It has to be in the corresponding worksheet in the VBA-Editor.
It activates when a cell in Range(A10:A20) has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A10:A20")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Count = 1 Then
If Target.Value = "x" Then
'Your Code
'i.e
MsgBox (Target.Address & "has been changed")
End If
Else
MsgBox ("Please No Copy Pasterino")
End If
End If
End Sub
EDIT:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim fRow As Long, lRow As Long
Dim check As Boolean
Dim sht As Worksheet
Dim Cell As Range
Set sht = Worksheets("Tabelle1")
'Rowcount
fRow = 2
lRow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & fRow & ":AI" & lRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each Cell In Range(Cells(fRow, Target.Column), Cells(lRow, Target.Column))
If Cell.Value = "x" Then
sht.Cells(9, Target.Column).Value = "x"
Exit For
Else
sht.Cells(9, Target.Column).Value = ""
End If
Next
End If
End Sub

Related

Highlight if 2 different values in a cell

would anyone be able to help?
I am trying to write VBA to highlight if the cell has 2 different values. It seems to highlight all including the same name appear twice. Thanks for any help!
Sub CountTwoOrMoreDifferent()
Dim myRange As Long
myRange = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:A" & myRange).Select
For Each AnimalName In Selection
AnimalNameMoreThan2 = AnimalName.Value
If InStr(AnimalNameMoreThan2, "Cat") + _
InStr(AnimalNameMoreThan2, "Dog") + _
InStr(AnimalNameMoreThan2, "Cow") _
+ InStr(AnimalNameMoreThan2, "Chicken") + _
InStr(AnimalNameMoreThan2, "Snake") + _
InStr(AnimalNameMoreThan2, "Tums") + _
InStr(AnimalNameMoreThan2, "Drop") > 1 Then
AnimalName.Interior.Color = vbRed
End If
Next AnimalName
End Sub
Data in column A
Sample Data
You can use this code.
It is split into two parts
a sub - which does the check per cell.
a function that checks if there is a duplicate within an array.
It returns true in case there is at least one dup.
Public Sub highlightDuplicateValues()
'get Range to check
Dim lastRow As Long, rgToCheck As Range
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rgToCheck = .Range("A2:A" & lastRow) 'no need to select!
End With
Dim c As Range, arrValuesInCell As Variant
Dim i As Long
For Each c In rgToCheck.Cells
'get an array of values/animals in cell
arrValuesInCell = Split(c.Value, ";")
'now check for each value if it has a dup - if yes color red and exit check
For i = LBound(arrValuesInCell) To UBound(arrValuesInCell)
If hasDupInArray(arrValuesInCell, i) = True Then
c.Interior.Color = vbRed
Exit For
End If
Next
Next
End Sub
Private Function hasDupInArray(arrValues As Variant, checkI As Long) As Boolean
'only values after the checkI-value are checked.
'Assumption: previous values have been checked beforehand
Dim varValueToCheck As Variant
varValueToCheck = arrValues(checkI)
Dim i As Long
For i = checkI + 1 To UBound(arrValues)
If arrValues(i) = varValueToCheck Then
hasDupInArray = True
Exit For
End If
Next
End Function

Create Hyperlink, when data is added to row, based on cell value

I have the below requirements:
Add hyperlink in Col A using address in Col D (Web Link), retain Col A display text and tooltip Col D file path address.
Add hyperlink in Col C using file path address in Col E, Col A and Col B (for Local network location). Retain Col C display text and Tooltip Col E, Col A and Col B file path address. The file naming follows this sequence "Data-002 Rev 00.pdf".
Add hyperlink in Col F "View File Local", same tooltip in Col C.
If Col E is blank Col C should not Add hyperlink in Col C and should retain the font style of Col C and Add text in Col F "File Not Found".
Retain all the Hyperlinks upon refresh of the table and only create new hyperlinks for the cell not having hyperlinks.
Since I am extracting the data from another table, the above order of documents might change, example "Data-002" might be in the 2nd Row when the data is refreshed because “Data-001” will be added after the refresh.
I don't know whether the VBA hyperlinks will retain its original linked address upon refresh, if yes, then Item 5 requirement is not required.
My end-users tend to delete the hardcoded hyperlink formulas in Col F. I want the hyperlink fixed so they cannot delete or modify.
The code below does most of the Hyperlink.Add but it keeps going for the entire rows and sheets in the workbook which causes the Excel file to freeze.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rColA As Range
Dim rColName As String
Dim LastRow As Long
Dim rColC As Range
Dim rColName1 As String
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set rColA = Range("A1:A" & LastRow)
If Intersect(Range("A1:A" & LastRow), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rColA In rColA
If rColA.Column = 1 Then
rColName = rColA.Value2
rColA.Parent.Hyperlinks.Add _
Anchor:=Cells(rColA.Row, 1), _
Address:=Cells(rColA.Row, 4), _
TextToDisplay:=rColA
rColA.Font.Size = 10
rColA.Font.Underline = False
End If
Next rColA
Set rColC = Range("C1:C" & LastRow)
If Intersect(Range("C1:C" & LastRow), Target) Is Nothing Then Exit Sub
For Each rColC In rColC
If Cells(rColC.Row, 5) <> "" Then
If rColC.Column = 3 Then
rColName1 = rColC.Value2
rColC.Parent.Hyperlinks.Add _
Anchor:=Cells(rColC.Row, 3), _
Address:=Cells(rColC.Row, 5) & Cells(rColC.Row, 1) & " Rev " & Cells(rColC.Row, 2) & ".pdf", _
TextToDisplay:=rColName1
rColC.Font.Size = 10
rColC.Font.Underline = False
End If
End If
Next rColC
Application.EnableEvents = True
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, rng As Range, c As Range, addr
LastRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
On Error GoTo haveError
'see if any cells of interest have changed
Set rng = Application.Intersect(Target, Me.Range("A1:A" & LastRow & ",C1:C" & LastRow))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each c In rng.Cells
Select Case c.Column 'select link address based on column
Case 1: addr = c.EntireRow.Columns("D")
Case 3: addr = Cells(c.Row, "E") & Cells(c.Row, "A") & " Rev " & Cells(c.Row, "B") & ".pdf"
End Select
c.Parent.Hyperlinks.Add Anchor:=c, Address:=addr, TextToDisplay:=c.Value2
c.Font.Size = 10
c.Font.Underline = False
Next c
Application.EnableEvents = True
End If
Exit Sub 'don't run into the error handler
haveError:
Application.EnableEvents = True 'make sure an error doesn't leave events turned off
End Sub
EDIT: I think this is probably closer to what you want. It'd easier just to treat each row as a unit, rather than try to track changes per-cell and only update certain links.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, rng As Range, rw As Range, addr, txt
LastRow = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
On Error GoTo haveError
'see if any cells of interest have changed
Set rng = Application.Intersect(Target.EntireRow, Me.Range("A1:F" & LastRow))
If Not rng Is Nothing Then
Application.EnableEvents = False
'loop over changed rows
For Each rw In rng.Rows
Me.Hyperlinks.Add anchor:=rw.Columns("A"), _
Address:=rw.Columns("D").Value, _
TextToDisplay:=rw.Columns("A").Value2
Me.Hyperlinks.Add anchor:=rw.Columns("C"), _
Address:=rw.Columns("E") & rw.Columns("A") & " Rev " & rw.Columns("B") & ".pdf", _
TextToDisplay:=rw.Columns("C").Value2
If Len(rw.Columns("E").Value) > 0 Then
Me.Hyperlinks.Add anchor:=rw.Columns("F"), _
Address:="{whatever is the path here}", _
TextToDisplay:="View file local"
Else
rw.Columns("E").Value = "File not found"
End If
With rw.Range("A1,C1,F1") 'Range() is *relative* to rw
.Font.Size = 10
.Font.Underline = False
End With
Next rw
Application.EnableEvents = True
End If
Exit Sub 'don't run into the error handler
haveError:
Application.EnableEvents = True 'make sure an error doesn't leave events turned off
End Sub

Change the values in a column depending upon different criteria

I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub

Iterative SUMIF Function Using VBA

Consider the following table:
What I would like to be able to do is create something like on the right hand side. This essentially requires telling Excel to sum all values for which the cell is zero until it encounters a 1, at which point it should begin the count again. I imagine this can be done using VBA, so I just need to determine how to actually set up that code. I imagine that the building blocks should be something like this:
Dim row As Long
Dim sum As List
row = Excel row definition
While ColB <> ""
If ColB.value = 0
Append ColC.value to Sum
Else Do Nothing
row = row + 1
Loop
Any help with the structure and syntax of the code would be much appreciated.
Try this:
Sub test()
Dim cel As Range, sRng As Range, oRng As Range, Rng As Range
Dim i As Long: i = 1
On Error GoTo halt
With Sheet1
.AutoFilterMode = False
Set Rng = .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
Rng.AutoFilter 1, 0
Set sRng = Rng.Offset(1, -1).Resize(Rng.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
Rng.AutoFilter 1, 1
Set oRng = Rng.Offset(1, 0).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
If sRng.Areas.Count >= oRng.Areas.Count Then i = 2
For Each cel In oRng.Areas
If i > sRng.Areas.Count Then Exit For
If cel.Cells.Count = 1 Then
cel.Offset(0, 1).Formula = _
"=SUM(" & sRng.Areas(i).Address(True, True) & ")"
Else
cel.Cells(cel.Cells.Count).Offset(0, 1).Formula = _
"=SUM(" & sRng.Areas(i).Address(True, True) & ")"
End If
i = i + 1
Next
Exit Sub
halt:
Sheet1.AutoFilterMode = False
End Sub
Edit1:
Above works regardless of how many zero's or one's you have in Column B.
If error occurs, it will exit. I leave the coding on how you want the error handled.

Deleting rows in excel using VBA depending on values found using a formula [duplicate]

This question already has answers here:
Delete Row based on Search Key VBA
(3 answers)
Closed 8 years ago.
Hey guys I am trying to write a code that deletes rows having values that are found using a formula. The problem is every other row is a #VALUE!, which I cannot change due to the setup of the report. In the end I want to delete all rows that have #VALUE! and any row that has values that are less than .75 in Column H.
The code I tried is as shown below:
Private Sub CommandButton1_Click()
Dim rng As Range, cell As Range, del As Range
Set rng = Intersect(Range("H1:H2000"), ActiveSheet.UsedRange)
For Each cell In rng
If (cell.Value) < .75 Then
If del Is Nothing Then
Set del = cell
Else: Set del = Union(del, cell)
End If
End If
Next cell
On Error Resume Next
del.EntireRow.Delete
End Sub
Any help or tips would be appreciated.
I suggest stepping backwards through the rows so that when a row is deleted you don't lose your place.
Assuming that you want to look at cells contained in column H you could do something like this:
Sub Example()
Const H As Integer = 8
Dim row As Long
For row = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
On Error Resume Next
If Cells(row, H).Value < 0.75 Then
Rows(row).Delete
End If
On Error GoTo 0
Next
End Sub
my code is an alternative to the other answers, its much more efficient and executes faster then deleting each row separately :) give it a go
Option Explicit
Sub DeleteEmptyRows()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim i&, lr&, rowsToDelete$, lookFor$, lookFor2$
'*!!!* set the condition for row deletion
lookFor = "#VALUE!"
lookFor2 = "0.75"
Set ws = ThisWorkbook.Sheets("Sheet1")
lr = ws.Range("H" & Rows.Count).End(xlUp).Row
ReDim arr(0)
For i = 1 To lr
If StrComp(CStr(ws.Range("H" & i).Text), lookFor, vbTextCompare) = 0 Or _
CDbl(ws.Range("H" & i).Value) < CDbl(lookFor2) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr) - 1) = i
End If
Next i
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)
For i = LBound(arr) To UBound(arr)
rowsToDelete = rowsToDelete & arr(i) & ":" & arr(i) & ","
Next i
ws.Range(Left(rowsToDelete, Len(rowsToDelete) - 1)).Delete Shift:=xlUp
Else
Application.ScreenUpdating = True
MsgBox "No more rows contain: " & lookFor & "or" & lookFor2 & ", therefore exiting"
Exit Sub
End If
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Try:
Private Sub CommandButton1_Click()
Dim rng As Range, cell As Range, del As Range, v As Variant
Set rng = Intersect(Range("H1:H2000"), ActiveSheet.UsedRange)
For Each cell In rng
v = cell.Text
If v < 0.75 Or v = "#VALUE!" Then
If del Is Nothing Then
Set del = cell
Else: Set del = Union(del, cell)
End If
End If
Next cell
On Error Resume Next
del.EntireRow.Delete
End Sub

Resources