I want to use a VBA Function to insert a formulas into cells based on two conditions.
The conditions are (1) there has to be something in the Description (Column D on my spreadsheet) and (2) the cell I'm pasting the code into has to be blank.
The best way I can see of doing this is with a loop, but I can't figure out how to update the references in my formulas to take account of the new position.
The code below works, but it does not check to see if the cells are empty first.
Range("B8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)))"
Range("B8").Select
Selection.AutoFill Destination:=Range("B8:B" & Total), Type:=x1filldefault
'Adds the above formula into the range B8 to B(the last cell in use)
Range("C8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,3,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,3,FALSE)))"
Range("C8").Select
Selection.AutoFill Destination:=Range("C8:C" & Total), Type:=x1filldefault
'Adds the above formula into the range C8 to C(the last cell in use)
Range("E8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,4,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,4,FALSE)))"
Range("E8").Select
Selection.AutoFill Destination:=Range("E8:E" & Total), Type:=x1filldefault
'Adds the above formula into the range E8 to E(the last cell in use)
Range("J8").Formula = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,9,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,9,FALSE)))"
Range("J8").Select
Selection.AutoFill Destination:=Range("J8:J" & Total), Type:=x1filldefault
'Adds the above formula into the range J8 to J(the last cell in use)
Range("A8").Formula = "=If(B8="""","""",Row(A8))"
Range("A8").Select
Untested, but this should do what you want.
In a loop:
For i = 8 to Total
If cells(i, 4) <> "" Then
AddFormulaIfNotBlank cells(i, 2), _
"=IF(D<r>="""","""",IF(ISERROR(VLOOKUP(Trim(D<r>),Sheet3!$B$8:$M$7500,2,FALSE))" _
& ","""",VLOOKUP(Trim(D<r>),Sheet3!$B$8:$M$7500,2,FALSE)))"
'add rest of formulas here....
Next i
Next i
Helper Sub: populate only empty cells, and adjust the formula for the current row
Sub AddFormulaIfNotBlank(c As Range, f As String)
If Len(c.value)=0 Then
c.formula = Replace(f, "<r>", c.Row)
End If
End sub
I've tested this briefly. it assumes that the currently selected cell is at the top of the column you want to work down through before you start the procedure. Also there isn't any error handling
Sub CopyFormulas()
Dim xlRange As Range
Dim xlCell As Range
Dim xlAddress As String
xlAddress = ActiveCell.Address & ":$" & Mid(ActiveCell.Address, 2, InStr(1, ActiveCell.Address, "$")) & Mid(Cells.SpecialCells(xlCellTypeLastCell).Address, InStrRev(Cells.SpecialCells(xlCellTypeLastCell).Address, "$"), Len(Cells.SpecialCells(xlCellTypeLastCell).Address))
Set xlRange = Range(ActiveCell, xlAddress)
For Each xlCell In xlRange
xlAddress = "D" & Mid(xlCell.Address, InStrRev(xlCell.Address, "$"), Len(xlCell.Address))
If xlCell.Value = "" And Range(xlAddress).Value <> "" Then
xlCell.Value = "=IF(D8="""","""",IF(ISERROR(VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)),"""",VLOOKUP(Trim(D8),Sheet3!$B$8:$M$7500,2,FALSE)))"
End If
Next xlCell
End Sub
I have two sheets in an excel file namely bank_form and Pay_slip.
I am trying to write a vba to check whether value/text in cell B5 of sheet Pay_slip is equal to value/text in cell B8 of sheet Bank_form. Similary it will check all values till the last row of sheet Pay_slip.
But my code is not working it always comes true i.e. it always flash the message "All employees found."
Please find my mistake(s).
Sub CommandButton1_Click()
Dim LastRow As Long
LastRow = Worksheets("Bank_form").Range("B" & Rows.Count).End(xlUp).Row
LR = Worksheets("Pay_slip").Range("B" & Rows.Count).End(xlUp).Row
If Worksheets("Pay_slip").Range("B5" & LR).Value = Worksheets("Bank_form").Range("B8" & LastRow) Then
MsgBox "All Employees Found."
Worksheets("Bank_form").Range("F" & LastRow + 1).Formula = "=SUM(F8:F" & LastRow & ")"
Else: MsgBox "Employee(s) missing Please check again!"
End If
End Sub
you will need a loop something like this
Dim i as Long
For i = 5 to LastRow 'start at B5
If Worksheets("Pay_slip").Range("B" & i).Value = Worksheets("Bank_form").Range("B" & i + 3) Then
' ... your other stuff here
next i
If Worksheets("Pay_slip").Range("B5").Value = Worksheets("Bank_form").Range("B8").Value Then MsgBox "The values are the same"
I have no idea why you involved the number of rows in your code but they are useless in order to check the equivalence in the values in a specific cell only
I would need to replace the line breaks in a cell, with a line break and the content of a cell in the same column of the active cell.
The code would be something like this:
For i = LBound(arColumns) To UBound(arColumns)
'ActiveColumn = arColumns(i)
Set rng = Range(arColumns(i))
For Each Cell In rng.Cells
If Cell.row > 4 And Cell.row < r Then
colnum=cell.column
Cell.value = "{Something}" & Cells(3, colnum).value & _
", text here{/something}" & Cell.value 'First line in the cell
cell.replace what:=vbCrLf, replacement:=vbCrLf & "{Something}" & _
Cells(3, colnum).value & ", text here{/something}" 'First try
Cell.value = Application.WorksheetFunction.Substitute(CStr(Cell.value), vbCrLf, vbCrLf & _
"{maxlen}{/maxlen}{notes}" & ", No Max length{/notes}") 'Second try
End If
Next
Next
I've tried to replace the values of the line breaks with the two methods, replace and substitute. None of them have been working or I am doing something wrong with this block of code.
The array arColumns have the range of columns that I want to work, for example: B:C,E:E,M:O,Z:AB...
along with the vbLf fix you've already been told, you could refactor your code as follows:
Option Explicit
Sub main()
Dim arColumns As Variant
Dim cell As Range
Dim r As Long, i As Long
arColumns = Array("B:C", "E:E", "M:O", "Z:AB")
r = 10 '<--| just to have a value to test with
For i = LBound(arColumns) To UBound(arColumns)
For Each cell In Intersect(Range(arColumns(i)), Rows("4:" & r)).SpecialCells(xlCellTypeConstants) '<--| loop through current columnns group not empty cells from row 4 to 'r'
cell.Replace what:=vbLf, replacement:=vbLf & "{Something}" & Cells(3, cell.Column).Value & ", text here{/something}" 'First try
Next
Next
End Sub
I have written a code for a command button in VBA that uses a (column) range as input and has a (column) range as output. I want to use the same code for other command buttons that refer to other columns. I do not want to repeat the entire code, as only the reference to the columns changes.
I cannot figure out how to define this code as a function or sub that I can 'call' in the code for other command buttons which execute the code on columns B, C, D, etc.
This is the code. It removes duplicates and adds the string "rename" to each element of the list:
Private sub rename_column_A_Click()
'copy values of sheet1 column A to active sheet
Range("A1:A30").Value = Worksheets("sheet1").Range("A1:A30").Value
'remove duplicates, keeping first value as column header
Columns("A:A").Select
ActiveSheet.Range("$A$2:$A$30").RemoveDuplicates Columns:=Array(1), _
Header:=xlNo
Range("A" & 2).Select
'add string to each element of list
For i = 2 To 30
If Not Range("A" & i).Value = "" Then
Range("A" & i).Value = "rename " & Range("A" & i).Value
End If
Next i
End Sub
Like John Coleman suggests, you can have your Sub take a Range parameter:
Private Sub rename_column_A_Click()
ProcessRange "A"
End Sub
Private Sub rename_column_B_Click()
ProcessRange "B"
End Sub
Sub ProcessRange(ColAddress As String)
'copy values of sheet1 column A to active sheet
Range(ColAddress & "1:" & ColAddress & "30").Value = Worksheets("sheet1").Range(ColAddress & "1:" & ColAddress & "30").Value
'remove duplicates, keeping first value as column header
ActiveSheet.Range("$" & ColAddress & ":$" & ColAddress & "$30").RemoveDuplicates Columns:=Array(1), Header:=xlNo
'add string to each element of list
For i = 2 To 30
If Not Range(ColAddress & i).Value = "" Then
Range(ColAddress & i).Value = "rename " & Range(ColAddress & i).Value
End If
Next i
End Sub
I removed the two Select lines of code. I don't think you need them.
I'm currently trying to use VBA to copy some cells from one location to another and because I'm new to VBA I was wondering if anyone could help me make my code a bit more efficient I know there must be a way to copy to a cell without having to select the cell and then copy to it
For i = 1 To dataSheet.Range("A" & dataSheet.Rows.Count).End(xlUp).Row
dataSheet.Range("A" & i & ":" & "CT" & i).Copy
Set rCell = dataSheet.Range("C" & i)
pasteSheet.Activate
If rCell = condition1 Then
With ActiveSheet
.Range("CU" & rowLoop2).Select
ActiveSheet.paste
End With
You have 2 options. Either use the .PasteSpecial method, or you can just reference the original range and set the new range to it's value.
.Range("CU" & rowLoop2).PasteSpecial Paste:=xlPasteAll
With the setting values option, you have to define the whole range which the values should fill.
Range("A3:E3").Value = Range("A1:E1").Value
If you just used Range("A3").Value = Range("A1:E1").Value only cell A3 would be populated, and it would take th value from cell A1. Hope this helps.
Edit: it's worth noting that you do not have to change sheets to paste either. Your code could be amended to the below:
With dataSheet
For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & i & ":" & "CT" & i).Copy
Set rCell = .Range("C" & i)
If rCell = condition1 Then
pasteSheet.Range("CU" & rowLoop2).PasteSpecial Paste:=xlPasteAll
End If
Next i
End With