Using VBA in excel, I am wanting to incorporate the formula located in column "O", shown below, for all B rows that have a value starting at B9. Please reference the image.
=""&D9&" "&I9&" (MK NO. "&B9&")"
This should do what your are looking for.
Sub Pasteformula()
Dim LookupRange As Range
Dim c As Variant
Application.ScreenUpdating = False
Set LookupRange = Range("B9:B500") ' Set range in Column B
For Each c In LookupRange 'Loop through range
If c.Value <> "" Then 'If value in B is empty then
Cells(c.Row, 15).FormulaR1C1 = _
"=""""&RC[-11]&"" ""&RC[-6]&"" (MK NO. ""&RC[-13]&"")""" 'Apply formula
End If
Next c
Application.ScreenUpdating = True
End Sub
Set the range and enter the formula, then change the range to values.
Sub Button1_Click()
Dim rng As Range
Set rng = Range("O9:O" & Cells(Rows.Count, "B").End(xlUp).Row)
rng.Formula = "=CONCATENATE(D9,"" "",I9,"" (MK NO. "",B9,"")"")"
rng.Value = rng.Value
End Sub
from your narrative I get that you already have the proper formula in O9, hence you could use AutoFill() method of Range object:
Range("O9").AutoFill Range("B9", Cells(Rows.Count, "B").End(xlUp)).Offset(,13)
Related
I am processing a data set that has about 50 columns, and the same columns are always off by a factor of ten. So, I just want to hardcode the specific columns (starting with F here) and divide every cell in the column by 10. Right now I am getting a "Type Mismatch" error. The code is below:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
cell.Value = cell.Value / 10
Next cell
End Sub
why loop when you can simply paste special and divide.
errors within the cells are ignored.
in vba, here is the code
Range("G10").Copy
Range("B2:E8").PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Application.CutCopyMode = False
test if cell is an error and then test if it is a number prior to dividing:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
If Not IsError(Cell) Then
If IsNumeric(cell) and cell <> "" Then
cell.Value = cDbl(cell.Value) / 10
End If
End If
Next cell
End Sub
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
In sheet "Selection" I input a Gender (M or F) in column A, and a corresponding value in column B.
In sheet "Sizes", I have lists of the available sizes for each gender, like this.
In sheet "Selection", I want it to write on Column C the corresponding size (that must be always be higher than column B). If there is not an available size, it must write "Not available!"
Enter the following formula in Cell C2 of Selection sheet
=IFERROR(IF(A2="M",INDEX(Sizes!$A$3:$A$10,MATCH(TRUE,Sizes!$A$3:$A$10>B2,0)),INDEX(Sizes!$B$3:$B$10,MATCH(TRUE,Sizes!$B$3:$B$10>B2,0))),"Not Available")
This is an array formula so commit it by pressing Ctrl+Shift+Enter. Drag/Copy down as required.
See image for reference
EDIT :
Following is VBA solution:
Sub Demo()
With Application
.ScreenUpdating = False 'stop screen flickering
.Calculation = xlCalculationManual 'prevent calculation while execution
End With
Dim selectionSht As Worksheet, sizeSht As Worksheet
Dim selectionLR As Long, sizeLR As Long, lastColumn As Long
Dim dict As Object
Dim rng As Range, cel As Range, genderRng As Range, valueRng As Range
Dim key As Variant
Dim colName As String
Set dict = CreateObject("Scripting.Dictionary")
Set selectionSht = ThisWorkbook.Sheets("Selection") 'Selection sheet
Set sizeSht = ThisWorkbook.Sheets("Sizes") 'Sizes sheet
selectionLR = selectionSht.Cells(selectionSht.Rows.Count, "A").End(xlUp).Row 'last row in Selection sheet
sizeLR = sizeSht.Cells(sizeSht.Rows.Count, "A").End(xlUp).Row 'last row in Sizes sheet
lastColumn = sizeSht.Cells(2, sizeSht.Columns.Count).End(xlToLeft).Column 'last column in Sizes sheet using row 2
Set valueRng = selectionSht.Range("B2:B" & selectionLR) 'data with value in Selection sheet
'storing all genders and corresponding column number from Sizes sheet in a dictionary
With sizeSht
Set rng = .Range(.Cells(2, 1), .Cells(2, lastColumn))
For Each cel In rng
dict.Add cel.Value, cel.Column
Next cel
End With
With selectionSht
For Each cel In .Range(.Cells(2, 3), .Cells(selectionLR, 3)) '3 is column no for results to be displayed
colName = Replace(.Cells(1, dict(CStr(cel.Offset(0, -2)))).Address(True, False), "$1", "") 'get column name from column 2
Set genderRng = sizeSht.Range(colName & "3:" & colName & sizeLR) 'set column for index/match formula
cel.FormulaArray = "=IFERROR(INDEX(Sizes!" & genderRng.Address & ",MATCH(TRUE,Sizes!" & genderRng.Address & ">" & cel.Offset(0, -1) & ",0)),""Not Available"")"
cel.Value = cel.Value
Next cel
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Let me know if anything is not clear.
You can use this (normal) formula in C2 and fill down:
C2:
=IFERROR(AGGREGATE(15,6,Sizes!$A$3:$B$10
/(Sizes!$A$2:$B$2=A2)/(Sizes!$A$3:$B$10>=B2),1), "Not Available!")
I have a spreadsheet that is updated regularly. Therefore the column header positions change regularly. eg. today "Username" is column K, but tomorrow "Username" might be column L. I need to add a new column to the right of "Username" but where it changes I cannot refer to as cell/column reference.
So far I have:
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find("Username")
When I go to add a new column to the right of it, I'm selecting that row but it's going back to cell/column references...
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Range("K1").Select
ActiveCell.FormulaR1C1 = "Role"
How can I perform this step with a macro?
edit: I think need to give that Column a header name and begin populating the row with data - each time I do begins the cell references which I want to avoid wherever possible.
Many thanks in advance.
How about:
Sub qwerty()
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find(what:="Username", After:=Cells(1, 1))
rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
rngUsernameHeader.Offset(0, 1).Value = "role"
End Sub
Sub AddColumn
Dim cl as Range
For each cl in Range("1:1")
If cl = "username" Then
cl.EntireColumn.Insert Shift:= xlToRight
End If
cl.Offset(0, 1) = "role"
Next cl
End Sub
Untested code as not at my desktop
Something like this should work. The idea is that you locate the column and then you insert to the right. That is why you have the +1 in the TestMe. The function l_locate_value_col returns the column, where it has found the value. If you want, you may change the optional parameter l_row, depending on which row do you want to look for.
Option Explicit
Public Sub TestMe()
Dim lngColumn As Long
lngColumn = l_locate_value_col("Username", ActiveSheet)
Cells(1, lngColumn + 1).EntireColumn.Insert
End Sub
Public Function l_locate_value_col(target As String, _
ByRef target_sheet As Worksheet, _
Optional l_row As Long = 1)
Dim cell_to_find As Range
Dim r_local_range As Range
Dim my_cell As Range
Set r_local_range = target_sheet.Range(target_sheet.Cells(l_row, 1), target_sheet.Cells(l_row, Columns.Count))
For Each my_cell In r_local_range
If target = Trim(my_cell) Then
l_locate_value_col = my_cell.Column
Exit Function
End If
Next my_cell
l_locate_value_col = -1
End Function
You could name your range:
Sub Test()
Dim rngUsernameHeader As Range
'UserName is in column F at the moment.
Set rngUsernameHeader = Range("UserName")
Debug.Print rngUsernameHeader.Address 'Returns $F$1
ThisWorkbook.Worksheets("Sheet2").Range("E:E").Insert Shift:=xlToRight
Debug.Print rngUsernameHeader.Address 'Returns $G$1
End Sub
Edit:
Have rewritten so it inserts a column after your named column and returns that reference:
Sub Test()
Dim rngUsernameHeader As Range
Dim rngMyNewColumn As Range
Set rngUsernameHeader = Range("UserName")
rngUsernameHeader.Offset(, 1).Insert Shift:=xlToRight
'You'll need to check the named range doesn't exist first.
ThisWorkbook.Names.Add Name:="MyNewRange", _
RefersTo:="='" & rngUsernameHeader.Parent.Name & "'!" & _
rngUsernameHeader.Offset(, 1).Address
Set rngMyNewColumn = Range("MyNewRange")
MsgBox rngMyNewColumn.Address
End Sub