I am trying to assign a value to all the odd cells in a particular column/range. So far I have the following code taken from another question, but it isnt working:
Sub changeClass()
Dim r As Range
Set r = Range("B16").End(xlDown) 'set the range the data resides in
For i = 1 To r.Rows.Count 'merge step
If i Mod 2 = 1 Then 'this checkes to see if i is odd
r.Cells.Value = "value"
End If
Else
r.Cells.Value = "value2"
Next i
End Sub
Basically I need it to add in a value for every cell in the B column from cell 16 down to the last cell i nthe column which has data in. On the even rows the value will be one thing, on the odd it will be another.
Many thanks!
Sub changeClass()
Dim r As Range
Dim i As Integer
For Each r In Range("B16:B24") 'Change this range
i = r.Row
If i Mod 2 = 1 Then 'this checks to see if i is odd
r.Cells.Value = "ODD"
Else
r.Cells.Value = "EVEN"
End If
Next r
End Sub
Try this out, I believe it is not working, because you are not acessing each individual cell inside your loop. In the following macro i use 'rng' to represent the entire range of cells, and 'r' to represent a single cell in each increment of the loop.
Sub changeClass()
Dim rng As Range
Dim r As Range
Set rng = Range(Cells(16,2),Cells(16,2).End(xlDown))
For i = 1 To rng.Rows.Count
Set r = rng.Cells(i)
If i Mod 2 = 1 Then ' You may want to test if it is odd based on the row number (depends on your problem...)
r.Value = "Odd Value"
Else
r.Value = "Even Value"
End If
Next i
End Sub
you've messed up your if statement, don't close it off before else close it only once you are completely done with it! ;) here:
Sub changeClass()
Dim r As Range
Set r = Range("B16").End(xlDown) 'set the range the data resides in
For i = 1 To r.Rows.Count 'merge step
If i Mod 2 = 1 Then 'this checkes to see if i is odd
r.Cells.Value = "value"
Else
r.Cells.Value = "value2"
End if
Next i
End Sub
You don't need a loop for this:
Sub OddRowAlert()
With Range("B16:B100")
.Formula = "=IF((MOD(ROW(B16),2)),""Odd"",""Even"")"
.Formula = .Value
End With
End Sub
Just replace odd and even in the formula with what you want
Related
I am creating a macro where in column B I need to fill and copy down the value above until the next value is found and again it is copied down until the next one and so and so.
Right now I have the following syntaxis:
Range("B:B").CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
It is working, but the "currentregion" is creating some data that I do not want. How can I replace that or change my syntaxis to make it work only in column B:B
First things first, be careful with Range("B:B").CurrentRegion - it will not necessarily include everything in column B as my example below shows. Next, this macro will copy cell values down to empty cells. Application.ScreenUpdating will speed it up if the range is large.
Sub CopyDown()
Dim rAll, r As Range
Set rAll = Range("B:B").CurrentRegion
Set r = Range("B2")
Application.ScreenUpdating = False
While Not Intersect(r, rAll) Is Nothing ' ie. r in the "current region"
If IsEmpty(r) Then r.Value = r.Offset(-1).Value ' copy down the value above
Set r = r.Offset(1) ' move down 1 row
Wend
Application.ScreenUpdating = True
End Sub
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub
Good day, I would love to ask you a question.
I have two colls with numbers and I need to compare first coll (longer) with second coll (shorter) and if there is a match, hide the row where the match occurs.
I have this so far:
Sub RowHide()
Dim cell As Range
Dim CompareCells As Range
Set CompareCells = Range("I2:I18")
For Each cell In Range("A2:A200")
If cell.Value = CompareCells Then
cell.EntireRow.Hidden = True
End If
Next
End Sub
My problem is that I don't know how to set value of CompareCells to start comparing. I'll appreciate every advice.
You have to set 2 separate ranges and compare them. If you want every cell compared with the one on the same line (A1 with B1, A2 with B2, etc) then consider using:
for i = 1 to something
set cell1 = range("A" & i)
set cell2 = range("B" & i)
if cell1.value = cell2.value then
'Do this, and do that!
cell1.entirerow.hidden = true
end if
next i
try this:
Sub RowHide()
Dim Longer As Range
Dim i As Double
i = 2 'Initial row
For Each Longer In Range("A2:A200")
If Longer.Value = Cells(i,2).Value Then
Longer.EntireRow.Hidden = True
End If
i = i + 1
Next
End Sub
PS:
Cells(RowIndex, ColumnIndex).Value: returns the value of the Row And Column.
ColumnIndex => Column A = 1, Column B = 2, an so on...
I looked into both of yours ideas and converted them into one and I finally get it working.
Here is my final code:
Sub RowHide()
Dim i As Integer
Dim j As Integer
For i = 2 To 197
Set FirstRange = Range("A" & i)
For j = 2 To 18
If FirstRange.Value = Cells(j, 8).Value Then
FirstRange.EntireRow.Hidden = True
End If
Next j
Next i
End Sub
Only modification if someone wants to use it is that you have to change numbers in for cycles according to number of rows in columns.
Thanks to both of you for your advices.
Is it possible to clear a large number of cells based on a value, i.e. if >1? I am using Excel for Mac 2011.
I would like to convert thousands of values >1 to empty cells in a large dataset (600 rows x 450K). The values are supposed to range from 0 to 1, but there are errors scattered throughout where the entry is >1 (1000-10000) and precludes averaging rows accurately.
BTW: I tried the previously posted macro for "clear cells based on color" after highlighting all cells with values >1, but this failed. I am guessing because the RGB lookup table instructions don't match my version of excel?
(Clear cell contents based on color?)
Select the area you wish to process and give this a try:
Sub ClearSome()
Dim r As Range, rr As Range, rClear As Range
Set rr = Intersect(Selection, ActiveSheet.UsedRange)
Set rClear = Nothing
For Each r In rr
If IsNumeric(r) Then
If r.Value > 1 Then
If rClear Is Nothing Then
Set rClear = r
Else
Set rClear = Union(rClear, r)
End If
End If
End If
Next r
If Not rClear Is Nothing Then
rClear.Clear
End If
End Sub
Given the size of your data it might be more efficient to read into an array and loop over the array and then write the array back to the worksheet.
Try this:
Sub RemoveValues()
Dim values(), arrayWidth As Integer, arrayHeight As Integer, i As Integer, j As Integer
values = Range("A1:C5") // update as per your set up
arrayWidth = UBound(values, 2)
arrayHeight = UBound(values, 1)
For j = 1 To arrayHeight
For i = 1 To arrayWidth
If values(j, i) > 1 Then
values(j, i) = vbNullString
End If
Next i
Next j
Range("A1").Resize(arrayHeight, arrayWidth) = values
End Sub
I am using the OFFSET Function to create a dynamic chart for the table depicted in the image below. Basically on the click of the button labeled "Copy Mean VCD Values" the code copies values from another sheet to the current sheet. If it encounters any cells with "#DIV/0!" I have it set to put "N/A" instead. But in this case I don't get a dynamic chart. If in stead of N/A I do "" it creates a dynamic chart but adds junk values "1" to the first set on the graph. I only get the desired results if I manually delete all the rows containing "N/A" below the last row containing data (See image for details).
https://lh6.googleusercontent.com/-OfjK6dSRQE8/U2JkdadjedI/AAAAAAAAABk/d8WDLuuC7Lk/w1068-h803-no/Offset+error.PNG
This is the code I am using for the Command Button "Copy Mean VCD Values":
Private Sub CommandButton2_Click()
r = 7
'//j increments the column number
'//i increments the row number
'//r is used for taking values from alternate cells(sheet3 column K) rowwise
For j = 2 To 14
For i = 7 To 26
If ThisWorkbook.Sheets(3).Range("K" & r & "").Text = "#DIV/0!" Then
ThisWorkbook.Sheets(2).Cells(i, j).Value = "N/A"
Else
ThisWorkbook.Sheets(2).Cells(i, j).Value = ThisWorkbook.Sheets(3).Range("K" & r & "").Value
End If
r = r + 2
Next i
Next j
End Sub
If I add the following code it works but it deletes the entire rows before and after the table. See image : https://lh6.googleusercontent.com/-WiM8HN61zkM/U2Jz2J_JxjI/AAAAAAAAACw/z4i3hlakyAI/w1598-h442-no/offset+delete+row.PNG
Private Sub CommandButton2_Click()
r = 7
'//j increments the column number
'//i increments the row number
'//r is used for taking values from alternate cells(sheet3 column K) rowwise
For j = 2 To 14
For i = 7 To 26
If ThisWorkbook.Sheets(3).Range("K" & r & "").Text = "#DIV/0!" Then
ThisWorkbook.Sheets(2).Cells(i, j).Value = "N/A"
Else
ThisWorkbook.Sheets(2).Cells(i, j).Value = ThisWorkbook.Sheets(3).Range("K" & r & "").Value
End If
r = r + 2
Next i
Next j
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B7:B26")
Do
Set c = SrchRng.Find("N/A", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Value = ""
Loop While Not c Is Nothing
End Sub
And this is OFFSET Function I am using for Column B in this case:
=OFFSET('Data Summary Template'!$B$7,0,0, COUNTA('Data Summary Template'!$B$7:$B$26),1)
I can't exactly replicate this problem you're having... I think the initial problem must have something to do with the warning regarding invalid references. You should look in to that and figure out the cause, which is probably the cause of "extra" data in your chart.
If deleting the N/A values appears to be working, try something. Instead of:
Set SrchRng = ActiveSheet.Range("B7:B26")
Do
Set c = SrchRng.Find("N/A", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Value = ""
Loop While Not c Is Nothing
Do this:
Dim tblCell as Range
Dim tbl as ListObject
Set tbl = ActiveSheet.ListObjects(1)
For each tblCell in tbl.DataBodyRange.Columns(2).Cells
If tblCell.Value = "N/A" Then
tblCell.Resize(1, tbl.DataBodyRange.Columns.Count - 1).Value = vbNullString
End If
Next