Macro to clear (a large number of) cells whose values are >1? - excel

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

Related

Copying Cell Value On The Same Row Based On Another Column Cell Color

I am trying to be able to search through a list in Column W and any cell in Column W that is highlighted Yellow to Copy Cell from Column B from the same row as colored cell in Column W.
This is what I have so far:
Sub CopyData()
Dim YellowField As Range
Dim YellowCell As Range
Dim Amortized As Worksheet
Dim Rollforward As Worksheet
Set Amortized = Worksheets("AMORTIZED")
Set Rollforward = Worksheets("Rollforward")
Set YellowField = Amortized.Range("W4", Amortized.Range("W4").End(xlDown))
For i = 4 To YellowField.UsedRange.Rows.Count
For Each YellowCell In YellowField
If YellowCell.Interior.Color = vbYellow Then
x = Amortized.Cells(i, ColumnD).Value
x.Copy Destination:= _
Rollforward.Range("B30").Offset(Rollforward.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
Exit For
End If
Next YellowCell
Exit For
Next i
End Sub
Currently when I run I get Error 439 on this line.
x = Amortized.Cells(i, ColumnD).Value
I was using .color and switched to .value because I feel it would assume if column D was colored I could be wrong though. Plus I feel I am still missing the loop here where the list would continue to be scanned for more colored cells in Column W
ColumnD is being read as a Variant it does not mean Column D Use 4 instead.
The inner loop is not needed and will give you a lot of false positive copies.
And to copy X you need to make it a Range and Set it. But in this case just use the cell itself.
Sub CopyData()
Dim LstRow As Long
Dim Amortized As Worksheet
Dim Rollforward As Worksheet
Set Amortized = Worksheets("AMORTIZED")
Set Rollforward = Worksheets("Rollforward")
LstRow = Amortized.Cells(Amortized.Rows.Count,23).End(xlUp).Row
For i = 4 To lstrow
If Amortized.Cells(i,23).Interior.Color = vbYellow Then
Amortized.Cells(i, 4).Copy Destination:= _
Rollforward.Cells(Rollforward.Rows.Count,2).End(xlUp).Offset(1,0)
End If
Next i
End Sub

Need to loop through column AI and if cell is not empty then look look in column W and move number in next column

HERE IS A NEW IMAGE HOPEFULLY SHOWING WHAT HAS TO MOVE AND WHERE'Here is a sample of some code I have been trying.
sub
For Each cel In Range("W2:W1000")
If cel.Value = "Credit Adj W/O To Collection" AND
Range("AI2:AI1000").Cells.Value > "" THEN
cel.Offset(0,-9).value =
end sub
Basically I need to look in column W for a specific text and if it is found move the number in the next column, col X over to column Y in the same row as the data in column AI, but in column Y. My issue is the amount of rows it has to move up is different based on where the data is in column AI. See screenshot
All of you have been a great help but it is still not moving any numbers. I added another screenshot. I need to look for the text in blue, if found move the amount in column X two columns right and up to the row that has a value in column AI. That gap could be different for each entry, as shown in the screen shot. could be 2 or 4 or 5, just depends on Column AI. Also first entry may not always start in the same row as it does here. The spot in column W and AI may be different throughout the spreadsheet. Hope this helps define my purpose a little.
Everyone has had great ideas but still not working, logic in answers makes sense but it is not grabbing any of the data much less move it. Not sure what is up.
Try this:
Sub tester()
Dim c As Range, ws As Worksheet, rw As Range
Set ws = ActiveSheet 'always use an explicit sheet reference
For Each c In ws.Range("W2:W1000").Cells
Set rw = c.EntireRow 'the whole row for the cell
If c.Value = "Credit Adj W/O To Collection" And _
IsNumeric(rw.Columns("X").Value) Then
'copy the value to Col Y in the row above which has a value in Col AI
ws.Cells(rw.Columns("AI").End(xlUp).Row, "Y").Value = rw.Columns("X").Value
rw.Columns("X").ClearContents ' clear the "X" value
End If
Next c
End Sub
A Tricky Column Update
Loop (r = r + 1) from the first row to the last row (the latter calculated in column W).
When column AI is not blank, write the row number to a variable (rFound).
Continue looping (r = r + 1). When column W is equal to the string Credit Adj W/O To Collection, write the value in column X of the current row to column Y of the row kept in the variable (rFound).
Continue looping (r = r + 1) by alternating between steps 2. and 3. until the last row.
Option Explicit
Sub UpdateInsAmt()
Const wsName As String = "Sheet1"
Const rStart As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rLast As Long: rLast = ws.Cells(ws.Rows.Count, "W").End(xlUp).Row
Dim r As Long: r = rStart
Dim rFound As Long
Do
If Len(CStr(ws.Cells(r, "AI").Value)) > 0 Then ' is not blank
rFound = r
r = r + 1 ' it can't be in the same row
Do
If StrComp(CStr(ws.Cells(r, "W").Value), _
"Credit Adj W/O To Collection", vbTextCompare) = 0 Then
ws.Cells(rFound, "Y").Value = ws.Cells(r, "X").Value
Exit Do ' value found and written so stop looping ...***
'Else ' value not found ...
End If
r = r + 1 ' ... so incremenet row
Loop Until r > rLast
' Else ' is blank ...
End If
r = r + 1 ' ... so increment row, ...*** and increment row
Loop Until r > rLast
End Sub

Copy values from cells in range and paste them in random cell in range

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

Non-contiguous For Each loop per row instead of column

I have a non-contiguous selection spanning rows and columns, and I want to do a For Each loop on it. Excel VBA does this by looping firstly down column 1, then 2,3 etc.; but I want it to loop along the row first instead.
(My sheet looks something like the picture below, I need to loop down the selection (version) each column in turn, and retrieve the Doc. No. and other information. The number of rows and version columns in the sheet is not fixed).
Short of writing a fairly large Sort function and creating an array of references, I was wondering if there was a 'built-in' way to do this?
I don't need code, just an explanation.
The order in which a For Each iterates an object collection is implementation-dependent (IOW blame Excel, not VBA) and, while likely deterministic & predictable, there is nothing in its specification that guarantees a specific iteration order. So VBA code written to iterate an object collection, should not be written with the assumption of a specific iteration order, since that's something that can very well change between versions of the type library involved (here Excel's).
It's very unclear what the shape of your Range / Selection is, but if you need to iterate the selected cells in a specific order, then a For Each loop should not be used, at least not for iterating the cells per se.
Since the ranges are not contiguous, the Range will have multiple Areas; you'll want to iterate the Selection.Areas, and for each selected area, iterate the cells in a particular order. For Each is, by far, the most efficient way to iterate an object collection, which Range.Areas is.
Debug.Assert TypeOf Selection Is Excel.Range
Dim currentArea As Range
For Each currentArea In Selection.Areas
'todo
Next
Instead of nesting the loops, make a separate procedure that takes the currentArea as a parameter - that procedure is where you'll be iterating the individual cells:
Private Sub ProcessContiguousArea(ByVal area As Range)
Dim currentRow As Long
For currentRow = 1 To area.Rows.Count
Debug.Print area.Cells(currentRow, 1).Address
Next
End Sub
Now the outer loop looks like this:
Debug.Assert TypeOf Selection Is Excel.Range
Dim currentArea As Range
For Each currentArea In Selection.Areas
ProcessContiguousArea currentArea
Next
The ProcessContiguousArea procedure is free to do whatever it needs to do with a given contiguous area, using a For loop to iterate the range by rows, without needing to care for the actual address of the selected area: using Range.Cells(RowIndex, ColumnIndex), row 1 / column 1 represents the top-left cell of that range, regardless of where that range is located in the worksheet.
Non-selected cells can be accessed with Range.Offset:
Debug.Print area.Cells(currentRow, 1).Offset(ColumnOffset:=10).Address
The top-left cell's row of the area on the worksheet is returned by area.Row, and the top-left cell's column of the area on the worksheet is retrieved with area.Column.
Non-Contiguous
By looping through the rows first (i), you will get the 'By Row sequence' e.g. A1,B1,C1, ...
The Code
Sub NonContiguous()
Dim i As Long
Dim j As Long
Dim k As Long
With Selection
For k = 1 To .Areas.Count
With .Areas(k)
For i = .Row To .Rows.Count + .Row - 1
For j = .Column To .Columns.Count + .Column - 1
Debug.Print .Parent.Cells(i, j).Address & " = " _
& .Parent.Cells(i, j)
Next
Next
End With
Next
End With
End Sub
This is based on urdearboy's suggestion:
1. loop over columns
2. within a column, loop over cells
Sub disjoint()
Dim r As Range, rInt As Range
Dim nLastColumn As Long
Dim nFirstColumn As Long, msg As String
Dim N As Long
Set r = Range("C3,C9,E6,E13,E15,G1,G2,G3,G4")
nFirstColumn = Columns.Count
nLastColumn = 0
msg = ""
For Each rr In r
N = rr.Column
If N < nFirstColumn Then nFirstColumn = N
If N > nLastColumn Then nLastColumn = N
Next rr
For N = nFirstColumn To nLastColumn
Set rInt = Intersect(Columns(N), r)
If rInt Is Nothing Then
Else
For Each rr In rInt
msg = msg & vbCrLf & rr.Address(0, 0)
Next rr
End If
Next N
MsgBox msg
End Sub

Excel odd rows give value

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

Resources