How do I replace all the 0 values in a range with a formula depending on the category it's in? - excel

On an excel sheet, if there is a list of numbers and next to it a letter to determine what category it's in, how would I be able to change blank or 0 values with a formula depending on the category?
In this case there's a list of price and weight for product a,b,and c. the average price for the products are already known and is in a table on the same excel sheet. To fill in the 0 data with an estimate of how much the product would've weighed, what would the code look like.
Sub test()
Dim RNG As Range
For Each RNG In Range("A2:A")
If RNG.Value = "0" And RNG.Offset(0, 2) = "a" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(2,5)"
If RNG.Value = "0" And RNG.Offset(0, 2) = "b" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(3,5)"
If RNG.Value = "0" And RNG.Offset(0, 2) = "c" Then RNG.Offset(0, 0).Formula = "=RC[1]/Cells(4,5)"
Next RNG
End Sub
The real data is thousands of lines so manually doing it is not prefered. There are a few things like the RNG.Offest(0,0) that I'm not particularly happy about but it doesn't return a syntax error so i've stuck with it.
Can anyone help me out?

If I'm not mistaken to understand what you want ...
The code below assumed that all the data rows in column D are unique.
Sub test1()
Dim rg As Range
Dim cell As Range
With ActiveSheet
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each cell In rg
If cell.Value = 0 Then _
cell.Value = cell.Offset(0, 1).Value / .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Find(cell.Offset(0, 2).Value, lookat:=xlWhole).Offset(0, 1).Value
Next
End With
End Sub
Sub test2()
Dim rg As Range
Dim cell As Range
Dim c As String
With ActiveSheet
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
For Each cell In rg
If cell.Value = 0 Then
c = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Find(cell.Offset(0, 2).Value, lookat:=xlWhole).Offset(0, 1).Address
cell.Value = "=" & cell.Offset(0, 1).Address & "/" & c & ""
End If
Next
End With
End Sub
Sub test1 will put a value to the cell which value = 0
Sub test2 will put a formula to the cell which value = 0
(based on your image attachment) :
cell A4 show a result from a calculation of : cell B4 value / cell E2 value = 1.0333
cell A7 show a result from a calculation of : cell B7 value / cell E3 value = 3.3293

Related

Excel VBA to test and color cells of specific columns

So I have some "working code". Specifically, I am looking at a Range in Excel, then if I see "Yes" in a cell, coloring it Yellow and doing it for all the other cells in the range. Works GREAT.
Now I would like to sort of tweak the Fixed Range and have Excel look at the each column header and only perform this coloring based on the suffixes that I say. In this case, I would only like it to do this evaluation on the columns ending in "_ty".
Here is the code I have to color the entire range of cells:
Sub ColorCellRange()
Dim c As Range
' Loop through all cells in range A1:E + last used Row in column A
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
'Look for Yes
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
'Color the cell RED
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next
End Sub
Current output of code
Another approach: scan the column headers and decide if to process the cells below.
Sub ColorCellRange()
Dim c As Range, hdr As Range, ws As Worksheet
Set ws = ActiveSheet 'or whatever
'loop over all headers in Row 1
For Each hdr In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
If hdr.Value Like "*_ty" Then 'is this a header we're interested in ?
For Each c In ws.Range(hdr.Offset(1), ws.Cells(Rows.Count, hdr.Column).End(xlUp)).Cells
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
c.Interior.Color = vbYellow
End If
Next c
End If ' like "_ty"
Next hdr
End Sub
try this:
Option Compare Text
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If c.Value Like "*Yes*" And Cells(1, c.Column).Value Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
or you can remove Option Compare Text and convert .value to low/upper case:
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If LCase(c.Value) Like "*yes*" And _
LCase(Cells(1, c.Column).Value) Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub

Search multiple ranges and return values to different cells

I'm trying to create a Display/Dashboard that lists cars sold within a month broken down by salesman.
I have an input sheet, where the cars are entered weekly.
I'm looking for a way to search the lists of cars sold each week and return the values under the corresponding salesman.
I used IF AND functions however don't believe these are suitable for what I am trying to achieve.
Monthly Display
[Weekly Input]
If I understand you correctly, and if you don't mind to change your "header" in sheet Display ... then first you need to copy your original workbook and test the following sub on the copied workbook.
First, make the header for sheet Display like this :
Each name is separated by one column. So Mark H will be in column L, and so on.
Step run the sub, please don't hit "play" to run the sub - because the sub is not complete in the select case ---> It only define the oFill for DB and PR.
I don't write a complete sub, but I hope this sample sub may help you to get started.
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim arr1: Dim arr2: Dim arr3
Dim rg As Range: Dim cell As Range: Dim oFill As Range
Dim x As String: Dim y As String
Dim j As Long: Dim i As Long
'set the worksheet as sh1 and sh2 variable, and set the range of sh1 column A as rg variable
Set sh1 = Sheets("Weekly Input")
Set sh2 = Sheets("Display")
Set rg = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
'this is the loop for 4 week in sheet Weekly Input
'where rg at the first iteration is column A
'2nd iteration is column L, and so on
For j = 1 To 4
'this is the loop to each row of data value in rg (the N/U column)
For Each cell In rg
'join the name, model, reg and date with comma separated into variable x
x = cell.Offset(0, 2).Value & "," & cell.Offset(0, 3).Value & "," & _
cell.Offset(0, 1).Value & "," & cell.Offset(0, 9).Value
'make x value into into array as arr1 variable
arr1 = Split(x, ",")
'join the prds, fin, px and discount with comma separated into variable y
y = cell.Offset(0, 5).Value & "," & cell.Offset(0, 6).Value & "," & _
cell.Offset(0, 7).Value & "," & cell.Offset(0, 8).Value
'make y value into array as arr2 variable
arr2 = Split(y, ",")
'create arr3 variable by joining arr1 and arr2
ReDim arr3(0 To 1, 0 To UBound(arr1))
For i = 0 To UBound(arr3, 2)
arr3(0, i) = arr1(i)
arr3(1, i) = arr2(i)
Next
'check what is the value of the looped row,column S/C
Select Case UCase(cell.Offset(0, 4).Value)
'if the value is DB
Case "DB"
'check, if the looped cell value is u, set the range in sh2 to a blank cell of column B as oFill variable
'other then "u" (meaning "n"), set the range in sh2 to a blank cell of column D as oFill variable
If cell.Value = "u" Then Set oFill = sh2.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) _
Else Set oFill = sh2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
'same thing with PR
'add a similar code for MH and MD pointing to the needed range
Case "PR"
If cell.Value = "u" Then Set oFill = sh2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0) _
Else Set oFill = sh2.Range("i" & Rows.Count).End(xlUp).Offset(1, 0)
End Select
'put the arr3 value into oFill
oFill.Resize(4, 2).Value = Application.Transpose(arr3)
'looped to the next row of column N/U in sh2
Next cell
'set the rg for the next iteration of the week
Set rg = rg.Offset(0, 11)
Next j
End Sub

Split zip code in a column into 2 columns

This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values ​​of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub

How can I Identify Range And Then Last Cell In Range And Insert Absolute Cell Address Into R1C1 Formula?

I have an Excel workbook with worksheets formatted as follows:
I have been trying to write some code that will populate the "% Weight" column with a formula that will divide the value of the adjacent cell in "Weight" column by the value of the cell that contains the sum function below each range of cells.
I have dozens of tables on a sheet, divided by a few blank rows, all formatted like this vertically. I need the cells to identify the correct sum cell and divide the offset cell by the value.
I have tried the below code.
Basically I tried to run a For Each loop through the "% Weight" column and identify when the adjacent cell in "Weight" was not empty. Then it would identify the offset cell by setting a range variable, and then set another variable to identify the final cell in the range therefore identifying the cell containing the sum formula.
I do know that my If logic is working though, as I had to populated "% Weight" column with a value of "1" if there was an adjacent cell and that worked.
I keep getting error 424 or type mismatch.
Code block providing issues:
Dim cell As Range, rng2 As Range, sideweight As Range, TargetWeight As Range
Dim TargetWeightr As Long, Dim TargetWeightc As Long
rng2 = Range("D1:D" & LR)
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
Set TargetWeightr = TargetWeight.Address.Row
Set TargetWeightc = TargetWeight.Address.Column
'cell.FormulaR1C1 = "=RC[-1]/R[" & TargetWeightr & "]C[" & TargetWeightc & "]"
End If
Next cell
Entire Macro For Context:
Sub WeightCalculations2()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range, rng2 As Range, rA As Range, totalweight As Range, totalweightrng As Range
Dim sideweight As Range, TargetWeight As Range
Dim LR As Long, TargetWeightr As Long, TargetWeightC As Long
Dim ws As Worksheet
Set ws = ActiveSheet
With ActiveSheet
LR = Cells(Rows.Count, "A").End(xlUp).Row
End With
Set rng = ws.Range("I2:I" & LR)
Set rng2 = ws.Range("J2:J" & LR)
For Each cell In rng
If cell.Offset(0, -1).Value = "EA" Then cell.FormulaR1C1 = "=RC[-2]*RC[3]"
If cell.Offset(0, -1).Value = "LB" Then cell.FormulaR1C1 = "=RC[-2]*1"
Next cell
For Each cell In rng
If WorksheetFunction.IsError(cell) Then cell.Formula = "=1*0"
Next cell
For Each rA In Columns("I").SpecialCells(xlFormulas).Areas
rA.Cells(rA.Cells.Count + 1).Formula = "=SUM(" & rA.Address & ")"
Next rA
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
Set TargetWeightr = TargetWeight.Address.Row
Set TargetWeightC = TargetWeight.Address.Column
'cell.FormulaR1C1 = "=RC[-1]/R[" & totalweightrn & "]C[" & totalweightcn & "]"
End If
Next cell
End Sub
Expected Output:
The program populates the cells in the column "% Weight" with the formula dividing the value of the corresponding offset cell in the "Weights" column by the value of the cell containing the sum for the corresponding range of cells.
Actual Output:
Error 424 and/or Error Mismatch.
TargetWeight.Address.Row should be TargetWeight.Row
TargetWeight.Address.Column should be TargetWeight.Column
When you create an xlR1C1 style address, the n inside [n] is a relative row or column adjustment. RC[-1] means same row, one column left. You want an absolute address and you have absolute row and column as long integers so R" & totalweightr & "C" & totalweightc
You don't Set integer values, you assign them with an =. You only Set objects like ranges, cells, worksheets, etc.
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sidewight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
TargetWeightr = TargetWeight.Row
TargetWeightc = TargetWeight.Column
cell.FormulaR1C1 = "=RC[-1]/R" & TargetWeightr & "C" & TargetWeightc
End If
Next cell
You might also want to forget all of the manipulation and just use TargetWeight.Address in xlR1C1 style.
For Each cell In rng2
If cell.Offset(0, -1).Value <> "" Then
Set sideweight = cell.Offset(0, -1)
Set TargetWeight = sideweight.End(xlDown)
cell.FormulaR1C1 = "=RC[-1]/" & TargetWeight.Address(referencestyle:=xlR1C1)
End If
Next cell

Copy and paste if one cell is blank and the other is not

So data gets pasted in to column B as the code keeps running it'll do a condition check to see there's any values in column B and paste a value in to the adjacent column A. I need to make it so it does two condition checks:
If there's values in column b, but then to check if there's values in column A before pasting so it doesn't overwrite different data that's been pasted already.
For Each Cell In y.Sheets("Compiled").Range("A:B")
If Range("B:B").Value <> "" And Range("A:A").Value = "" Then
Cell.Offset(0, -1).PasteSpecial xlPasteValues
End If
Next
You were close, don't try to loop over a multiple column range:
Sub Test()
For Each Cell In y.Sheets("Compiled").Range("B:B")
If Cell.Value <> "" And Cell.Offset(0, -1).Value = "" Then
Cell.Offset(0, -1).Value = Cell.Value
End If
Next
End Sub
NOTE: You are looping through every cell in Range("B:B") which is probably unnecessary. It'd be better if you use a lastrow value, or a static range like Range("B2:B1000"). Or you could use a criteria to exit your loop like If Cell.Value = "" Then Exit For.
Here's a version of the code that implements the lastrow value that dwirony mentioned in their answer. This also throws everything in arrays, so it might go a bit faster if you have a really large dataset.
Option Explicit
Sub test()
Dim ACol As Variant
Dim BCol As Variant
Dim lastrow As Long
Dim i As Long
lastrow = Range("B:B").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).row
BCol = Range("B1:B" & lastrow).Value
ACol = Range("A1:A" & lastrow).Value
For i = LBound(BCol) To UBound(BCol)
If IsEmpty(ACol(i, 1)) And Not IsEmpty(BCol(i, 1)) Then
ACol(i, 1) = BCol(i, 1)
End If
Next i
Range("A1:A" & lastrow).Value = ACol
End Sub

Resources