I'm trying to add a unit of 1 to many cells in a range. Below is where I'm at and I keep getting a type mismatch error:
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If cell.Value > 0 Then
cell.Value = cell.Value + 1
End If
Next
Here's another way
Sub Sandwich()
Dim rTemp As Range
Dim rTarget As Range
Dim sNumFmt As String
'Define the ranges
Set rTemp = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
Set rTarget = Sheet2.Range("D2:E1000")
'store a temporary value and the current number format
rTemp.Value = 1
sNumFmt = rTarget.Cells(1).NumberFormat
'copy and paste special-add
rTemp.Copy
rTarget.PasteSpecial , xlPasteSpecialOperationAdd
'get rid of the temp and reapply the format
rTemp.ClearContents
rTarget.NumberFormat = sNumFmt
End Sub
How about:
Sub marine()
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If IsNumeric(cell.Value) Then
If cell.Value > 0 Then
cell.Value = cell.Value + 1
End If
Else
MsgBox "Cell " & cell.Address(0, 0) & " does not have a number"
Exit Sub
End If
Next
End Sub
Stopping at OK, I'm trying to add a unit of "1" to many cells in a range. the easiest way is often without VBA or code. Just insert 1 somewhere on the spreadsheet, copy that cell, select the range of interest and Paste Special with Operation Add. The 1 can then be deleted.
Dim r As Range, cell As Range
Set r = Range("D2:E1000")
For Each cell In r
If cell > 0 Then
cell.Value = cell.Value + 1
End If
Next
Is Working for me , perhaps you want IF cell = 0 ???
Waiting for your comments to see if i anwsered your question.
Related
I'm trying to write something up that will search a specific range for specific numbers.
EX:
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
DO THIS
ElseIf InStr(cell.Value, "154") > 0 Then
DO THIS
etc...
I used instr since the cell will have things like "word 1 word 2 260 word 3."
For every match it finds within that range, I want to put a certain value into the same row in a different column.
Suggestions? Thanks in advance!
Try This:
Sub testing()
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
cell.Offset(0, 2).Value = "Found 260"
ElseIf InStr(cell.Value, "154") > 0 Then
cell.Offset(0, 2).Value = "Found 154"
End If
Next
End Sub
create an array of the items you want to look up then loop that with a built in lookup function.
Then use the row number returned to find the value you want. It will be quicker
Dim lkupArr()
lkupArr = Array(260, 154)
Dim i As Long
For i = LBound(lkupArr) To UBound(lkupArr)
Dim lkuprow As Long
lkuprow = 0
On Error Resume Next
lkuprow = Application.WorksheetFunction.Match("*" & lkupArr(i) & "*", ActiveSheet.Range("E:E"), 0)
On Error GoTo 0
If lkuprow > 0 Then
MsgBox lkupArr(i) & " found on row " & lkuprow & "."
'Then just use the return to return the value from the column you want
'The following returns the value in column F on the same row.
Dim ret
ret = ActiveSheet.Cells(lkuprow, "F").Value
Debug.Print ret
End If
Next i
Maybe not the most elegant solution, however does not make extensive use of the spreadsheet, so performance wise (if you have a lot of data to process), should be better than other solutions so far.
Function SearchAndFind()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngValues As Range
Dim arrRng As Variant, arrFind As Variant
Dim i As Long, j As Long, newColOffset As Long
'Adjust as needed
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set rngValues = ws.Range("E5:E112")
arrRng = rngValues
arrFind = Array("260", "154")
newColOffset = 2
For i = LBound(arrRng) To UBound(arrRng) 'loop through the given range, first column only
For j = LBound(arrFind) To UBound(arrFind) 'loop through items to find
If InStr(arrRng(i, 1), arrFind(j)) > 0 Then 'found the value
'Return the values
rngValues.Cells(1, 1).Offset(i - 1, newColOffset).Value = arrRng(i, 1)
Exit For
End If
Next j
Next i
End Function
I have the following case:
1.Column D populated with about 100 values,
2. Using these I create a validation in the Column A cells
3. If I have a value in Cell "A1", this particular value should not appear
in Cell "A2" dropdown list, now the values in "A1" and "A2" should not appear in "A3" and so on.
What should be the thought process to write the VBA code for this?
I found this one interesting, so check this out... Should work as you expect it...
Post this code into your Worksheet and adapt it for your needs (if necessary). Hope it helps.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim dict As Object
Dim dictAlreadyTaken As Object
Dim valueRange As Range
Dim targetRange As Range
Dim cell As Object
Dim Key As Variant
Dim currentList() As Variant
Dim i As Integer
If Target.Column = 1 Then
Set ws = Worksheets(1)
Set dict = CreateObject("Scripting.Dictionary")
Set dictAlreadyTaken = CreateObject("Scripting.Dictionary")
Set valueRange = ws.Range("D:D")
Set targetRange = ws.Range("A:A")
For Each cell In valueRange
If cell.Value <> "" Then
dict.Add cell.Value, cell.Row
Else
Exit For
End If
Next cell
For Each cell In targetRange
If cell.Row <= dict.Count Then
If cell.Value <> "" Then
'ad the value taken
dictAlreadyTaken.Add cell.Value, cell.Row
End If
Else
Exit For
End If
Next cell
For Each cell In targetRange
If cell.Row <= dict.Count Then
'add this list
Erase currentList
ReDim currentList(0)
i = 0
ws.Cells(cell.Row, 1).Validation.Delete
For Each Key In dict.keys
If Not dictAlreadyTaken.exists(Key) Then
i = i + 1
ReDim Preserve currentList(i) As Variant
currentList(i) = Key
End If
Next Key
If UBound(currentList) > 0 Then
ws.Cells(cell.Row, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(currentList, ",")
End If
Else
Exit For
End If
Next cell
End If
End Sub
My thought process would be:
First loop to list all the ranges we need to compare:
Cells(1,1) should not appear in Range(Cells(1,4),Cells(1,4))
Cells(2,1) should not appear in Range(Cells(1,4),Cells(2,4))
Cells(3,1) should not appear in Range(Cells(1,4),Cells(3,4)) ...etc...
Easy enough. Now that we know what ranges to compare, loop through the comparisons:
re: Cells(3,1) should not appear in Range(Cells(1,4),Cells(3,4)) :
.
Dim c as range
For Each c in Range(Cells(1,4),Cells(3,4))
If c.Value = Cells(1,4).Value then
'it's a match! Delete it (or whatever)
c.Value = ""
End If
Next c
Finally, put the two loops together...
From what I understand of your description, I came up with this:
Sub compareCells()
Dim c As Range, x As Integer
For x = 1 To 10
Debug.Print "Cells(" & x & ",1) should not appear in Range(Cells(1,4),Cells(" & x & ",4))"
For Each c In Range(Cells(1, 4), Cells(x, 4))
Debug.Print "compare " & Cells(x, 1).Address & " to " & c.Address
If Cells(x, 1).Value = c.Value Then
Cells(x, 1).Cells.Font.Color = vbBlue
End If
Next c
Next x
End Sub
It should be easily adaptable to your needs, or if not, there are plenty of existing solutions & resources, even a Stack Overflow tag: cascadingdropdown
Here is an approach:
Select a column in your sheet that you can use for a named range (this column can be hidden). For the purpose of example below, I've used column J and my named range is called ValidationRange. I have also assumed that the values in your worksheet start from row 2.
Now in a module, add the following sub:
Sub SetDropDownRange()
Dim oNa As Name: Set oNa = ThisWorkbook.Names.Item("ValidationRange")
Dim iLR&, iC&, iLRJ&
Dim aDRange As Variant
Dim aVRRange As Variant
With ThisWorkbook.Worksheets("Sheet12")
iLR = .Range("D" & .Rows.count).End(xlUp).Row
iLRJ = .Range("J" & .Rows.count).End(xlUp).Row
aDRange = Range("D2:D" & iLR)
For iC = LBound(aDRange) To UBound(aDRange)
If Len(Trim(aDRange(iC, 1))) <> 0 Then
If Application.WorksheetFunction.CountIf(Range("A:A"), aDRange(iC, 1)) = 0 Then
If IsArray(aVRRange) Then
ReDim Preserve aVRRange(UBound(aVRRange) + 1)
Else
ReDim aVRRange(0)
End If
aVRRange(UBound(aVRRange)) = aDRange(iC, 1)
End If
End If
Next
End With
Range("J2:J" & iLRJ).Value = ""
Range("J2:J" & UBound(aVRRange) + 2).Value = Application.Transpose(aVRRange)
oNa.RefersTo = oNa.RefersToRange.Resize(UBound(aVRRange) + 1, 1)
End Sub
Now call this function when something changes in your worksheet.. like so:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Or Target.Column = 4 Then
SetDropDownRange
End If
End Sub
Set Data Validation for the cells in column A using the named range (which is ValidationRange for this example)
Now everytime your select a value in column A, it will remove that value from the named range and hence from your dropdown box
I've written code to loop through a range for a specific value. If the value equals "123" then highlight the entire row green. However, I only want it to highlight the very first two matches it finds and stop there. Many thanks.
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
End If
Next
End Sub
It's better if you avoid using Select and other relatives, instead use referenced Objects, Sheets and Ranges.
Also, you can search for the last row with data in Column L instead of just looping through row 10000.
Option Explicit
Sub Macro3()
Dim Rng As Range, cell As Range
Dim counter As Integer, LastRow As Long
With Sheets("XYZ")
' find last row at Column "L"
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
Set Rng = .Range("L2:L" & LastRow)
For Each cell In Rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1
End If
If counter >= 2 Then Exit For
Next
End With
End Sub
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
dim count as integer
'Set the range in column D to loop through
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
count = count + 1
End If
if count >= 2 Then exit For
Next
End Sub
Filtering lets you avoid looping through cells
Assuming row 1 has header, you can try:
Dim cell As Range
Dim counter As Integer
With Sheets("XYZ")
With .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)) '<--| reference its column "L" cells from row 1 (header) down to last not empty row
.AutoFilter field:=1, Criteria1:="123" '<--| filter referenced range on its first (and only) column with "123"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell gets filtered
For Each cell In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells, skipping header
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1 '<--| update counter
If counter = 2 Then Exit For '<--| exit at 2nd iteration
Next cell
End If
End With
.AutoFilterMode = False
End With
Here's your code with some addition:
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
greenrows = 0
Sheets("XYZ").Select
Set rng = Range("b2:b10000")
For Each cell In rng
If cell.Value = "123" Then
If greenrows = 2 Then Exit Sub
cell.EntireRow.Interior.ColorIndex = 4
greenrows = greenrows + 1
End If
Next
End Sub
I need to create output like the following:
Column A | Column B
1. 1 1
2. 1
3. 2 2
4. 2
5. 2
So far, I have written the following code:
Sub ItemNum()
Dim rng As Range
Dim i As Long
Dim cell
Set rng = Range("A1:A99")
i = 1
For Each cell In rng
If (...) Then
cell.Offset(0, 1).Value = i
End If
Next
End Sub
I have already obtained the number sequence in column A. I need to add the same value in column B down to the column.
I would like to know how to add to increment statement.
Thanks
If what you are wanting to do is place a value from column A into every cell in column B until you come to another value in Column A, then the following should work:
Sub ItemNum()
Dim rng As Range
Dim i As Variant
Dim cell
Set rng = Range("A1:A99")
i = "Unknown"
For Each cell In rng
If Not IsEmpty(cell) Then
i = cell.value
End If
cell.Offset(0, 1).Value = i
Next
End Sub
You can do this without loops (quicker code):
Sub FastUpdate()
Dim rng1 As Range
Set rng1 = Range([a2], Cells(Rows.Count, "a").End(xlUp))
'add two rows
Set rng1 = rng1.Resize(rng1.Rows.Count + 2, 1)
'add first row
[b1].Value = [a1].Value
With rng1
.Offset(0, 1).FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-1],R[-1]C)"
.Offset(0, 1).Value = .Offset(0, 1).Value
End With
End Sub
If you use a For...Next loop instead of For...Each loop then you can use the counter variable to address the cells in column B:
Option Explicit
Sub ItemNum()
Dim rng As Range
Dim lngCounter As Long
Dim strCellValue As String
Set rng = Range("A1:A99")
strCellValue = 0
For lngCounter = 1 To rng.Cells.Count
If rng(lngCounter, 1).Value <> "" Then
strCellValue = rng(lngCounter, 1).Value
End If
rng(lngCounter, 2).Value = strCellValue
Next
End Sub
E.g.
If i understand correctly, below is the answer for you.
Assuming your data starts with A2 then Apply the below formula in B2 and drag down up to the last
=IF(A2<>"",A2,B1)
Note: A column data may be Number or anything.
Proof
I have a macro that puts 0 instead of blank rows there are more than 65000 of them everything works fine but problem is macro stops at line 62000 even if there is data on a next rows. Here is the code:
Sub QuickCull()
On Error Resume Next
Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
Columns("b").SpecialCells(xlBlanks).EntireRow.Delete
Columns("d").SpecialCells(xlBlanks).EntireRow.Delete
Dim col As Range
Set col = Cells(Rows.Count, "E").End(xlUp)
Dim r As Range
Set r = Range("E2", col).Resize(, 4)
Dim cell As Range
For Each cell In r
If cell.Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End If
Next cell
Cells("J1").Activate
End Sub
It seems to me problem is with ranges but not sure at all. What could cause this?
The Range.Cells property does not accept the same style of cell address references that a Range object does.
Cells("J1").Activate
'should be,
Range("J1").Activate
If columns E:H are having their values changed to 1 and their blanks changed to 0 then you can continue with the Range.SpecialCells method using xlCellTypeBlanks and xlCellTypeConstants.
Sub QuickCull()
Dim col As Range, r As Range
With Worksheets("data") '<~~ you should know ehat worksheet you are on!
On Error Resume Next
.Columns("a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("b").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns("d").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set col = .Cells(Rows.Count, "E").End(xlUp)
Set r = .Range("E2", col).Resize(col.Row - 1, 4)
r.SpecialCells(xlCellTypeConstants) = 1
r.SpecialCells(xlCellTypeBlanks) = 0
.Range("J1").Activate '<~~ or .Cells(4, "J").Activate
End With
End Sub