I'm close to what i want to do but not sure if I'll have to change method completely to get this done.
The below code works almost completely. I want to find all empty cells in range: C2:C120 and enter a formula from another worksheet: Worksheets("Sheet2").Range("F57").
It finds empty cells but it copies the text in the F57 cell, which is #N/A at the moment, not the formula. The formula is =VLOOKUP(D57,'[Example.xlsx]Sheet1'!$A$2:$D$37,2) but I can't enter it directly into the code as it will always look for D57, not dynamically.
Any help is hugely appreciated, hopefully it's a simple fix.
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet1")
For Each rng In ws.Range("C2:C120")
If IsEmpty(rng) Then
rng.Formula = Worksheets("Sheet2").Range("F57")
End If
Next
End Sub
I couldn't find an answer for this specifically though I'm sure i've come accross one before.
If I understand correctly, the following should work.
In your loop you can reference the rng row number in your formula.
You could use (note, not tested):
For Each rng In ws.Range("C2:C120")
If IsEmpty(rng) Then
rng.Formula = "=VLOOKUP(D" & rng.Row & ",'[Example.xlsx]Sheet1'!$A$2:$D$37,2)"
End If
Next rng
This uses the Row property of the Range object, which is the row number of whatever cell you are accessing in your loop in each iteration, and uses it as the row number for your D57 part of your formula (per your posted formula).
Update Data From Different Workbook
Adjust the constants in updateCustomers.
The Code
Sheet1 (or wherever you have CommandButton3)
Option Explicit
Private Sub CommandButton3_Click()
updateCustomers
End Sub
Module1
Sub updateCustomers()
' Source
Const wbsName As String = "Example.xlsx"
Const srcName As String = "Sheet1"
Const srcAddr As String = "A2:B37"
' Target
Const tgtName As String = "Sheet1"
Const LookupCol As String = "A"
Const tgtAddr As String = "C2:C120"
' Ranges
Dim src As Range
Set src = Workbooks(wbsName).Worksheets(srcName).Range(srcAddr)
Dim tgt As Range
Set tgt = ThisWorkbook.Worksheets(tgtName).Range(tgtAddr)
' The Loop
Dim cel As Range
For Each cel In tgt.Cells
If IsEmpty(cel) Then
On Error Resume Next
cel.Value = WorksheetFunction _
.VLookup(tgt.Parent.Cells(cel.Row, LookupCol).Value, src, 2, False)
On Error GoTo 0
End If
Next
MsgBox "Customers updated.", vbInformation, "Success"
End Sub
Related
I am editing my question to make it more explicit.
I have an excel with school tuition payments in a table where each row is a monthly payment. I want to lock all the rows that have been paid (that is if there is amount in column E) so that it cannot be erased or changed without a password.
The rows that have been paid are not necessarily in order.
I have tried a ton of different VBA codes that I have found here. But none of them have worked for me (some of them work but they only lock the rows that I´m editing at that moment and not all the rows that have values in Column E)
I have never worked with VBA...But I have to fix this. I am in a Mission School in Ecuador and I don´t know anyone who can help me... I really need to fix this soon because the secretary has already accidently erased data (!!!)
Lock Row If Not Blank
Adjust the values in the constants section.
Standard Module e.g. Module1
Option Explicit
Sub lockNonBlankRows()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const Cols As String = "A:E"
Const pw As String = "123"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Create a reference to the non-empty range.
Dim rg As Range
Dim cCount As Long
With ws.Columns(Cols).Rows(FirstRow)
cCount = .Columns.Count
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub
Set rg = .Resize(lCell.Row - .Row + 1)
End With
ws.Unprotect pw
Dim rrg As Range
' Loop through the rows of the non-empty range.
For Each rrg In rg.Rows
' Check if all cells in the current row range are blank.
If Application.CountBlank(rrg) = cCount Then
rrg.Locked = False
Else
rrg.Locked = True
End If
Next rrg
ws.Protect pw
wb.Save
End Sub
Additionally, you could call this procedure in some of the ThisWorkbook event procedures (not all of them), e.g.:
ThisWorkbook Module
Option Explicit
Private Sub Workbook_Open()
lockNonBlankRows
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
lockNonBlankRows
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
lockNonBlankRows
End Sub
First you protect the worksheet with UserInterfaceOnly. For this topic see Error 1004 when setting Range.Locked.
Place the following Sub in a VBA module, put the cursor somewhere into it and press F5:
Public Sub LockActiveSheet()
ActiveSheet.Protect UserInterfaceOnly:=True
End Sub
Then you can unlock empty cells and lock cells containing value in columns A:E with the following code in the same VBA module. Make sure that the worksheet 'PENSIONES' is open. Then put the cursor into it and press F5.
Public Sub LockNonEmptyCells()
Dim lngLastRow As Long 'index of the last used row
Dim rngAE As Range 'the range from cell A3 to Exxx (last used row)
Dim i As Long 'counter in For...Next
lngLastRow = [A1].SpecialCells(xlLastCell).Row 'get index of last used row
Set rngAE = [A3].Resize(lngLastRow - 2, 5) 'get data range
With rngAE.Cells 'cycle through all cells
For i = 1 To .Count
.Item(i).Locked = Not IsEmpty(.Item(i)) 'unlock empty cells, lock cells with value
Next i
End With
End Sub
For future editing you can paste the following code in the code module of the worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <= 5 Then Target.Locked = True
End Sub
This will lock the cell directly after you have entered a value.
I would like a code to check every cell in range A1:A14 and if the cell is highlighted say yes or no in column B.
.
Sub highlighted()
Dim rng As Range
Dim c As Range
Set rng = ActiveCell
For Each c In rng
If c.Interior.Pattern <> xlNone Then
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "Yes"
Exit Sub
End If
Next c
End Sub
This code works sucsessfully for one single highlighted cell, how can I get it to loop through my desired range, and also include the "no" for non-highlighted cells?
Thanks In Advance!
This would be the code. Read the comments and adjust according your needs.
Sub highlighted()
Dim evaluatedRange As Range
Dim evaluatedCell As Range
Dim sheetName As String
Dim rangeAddress As String
' Adjust these two parameters
sheetName = "Sheet1" ' Sheet name where the range is located
rangeAddress = "A1:A14"
Set evaluatedRange = ThisWorkbook.Worksheets(sheetName).Range(rangeAddress)
' This will loop through each cell in the range
For Each evaluatedCell In evaluatedRange
' Evaluates if the cell has a pattern (what ever it is)
If evaluatedCell.Interior.Pattern <> xlNone Then
' Set the value of the cell next to the one evaluated (same row - rowOffset:=0 but next column columnOffset:=1) to Yes
evaluatedCell.Offset(rowOffset:=0, columnOffset:=1).Value = "Yes"
' Exit Sub -> This would exit the whole process, so if you want to evaluate the whole range, just delete this line
Else
evaluatedCell.Offset(rowOffset:=0, columnOffset:=1).Value = "No"
End If
Next evaluatedCell
MsgBox "Process finished!" ' -> alert the user...
End Sub
If this is what you need, remember to mark the answer to help others.
If I understand what you are trying to do, you could simply do:
Sub highlighted()
Dim rng As Range
Dim c As Range
Set rng = Range("A1:A14")
For Each c In rng
If c.Interior.Pattern <> xlNone Then
c.Range("A1").Offset(0,1).Value = "Yes"
End If
Next c
End Sub
See How to avoid using Select in Excel VBA for tips on avoiding unneeded Selects
I have a workbook, with multiple sheets, which have comments. I have to loop through each of the sheets and pick up the comments. I have implemented the following logic.
For Each Ip_Sheet In ActiveWorkbook.Worksheets
Set Rng = Ip_Sheet.Cells.SpecialCells(xlCellTypeComments)
If Rng Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In Rng
Comment_Author_NameAndComment = Split(cell.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
The above logic works fine if there are no merged cells in the worksheet. However, if there are merged cells/rows, the loop For Each cell In Rng runs for each of the cells in the merged cells range. For example, if columns A:D are merged, then the loop runs for each of the cells A, B, C and D and I get the same value in the AuthName and AuthComments variables.
My question is, how do I make the loop to skip to the next comment on the worksheet if I find a merged cell?
Edit:
I also tried to loop through all the comments in the sheet by the following method, however, the method was not successful - the Rng.Comment object was always empty.
For Each cmnt_obj In Rng.Comment
cmt_txt = cmnt_obj.Text
Next cmnt_obj
Since SpecialCells(xlCellTypeComments) returns all cells for a Merged Range, you need to detect when a cell is part of a named range and only process one of those cells. You can use Range.MergeCells to detect a merged cell, and Range.MergeArea to return the merged range itself. Then only report the comment if the cell is the Top Left cell of the merged range.
Something like this:
Sub Demo()
Dim rng As Range
Dim cl As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
If Not rng Is Nothing Then
For Each cl In rng.Cells
If cl.MergeCells Then
If cl.Address = cl.MergeArea.Cells(1).Address Then
ReportComment cl
End If
Else
ReportComment cl
End If
Next
End If
Next
End Sub
Sub ReportComment(cl As Range)
Dim Comment_Author_NameAndComment() As String
Dim AuthName As String
Dim AuthComments As String
Comment_Author_NameAndComment = Split(cl.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
Debug.Print AuthName, AuthComments
'...
End Sub
I have a problem with the following code. I would like it to loop through a range (AK2 until end of data) and then any time it finds an empty cell it changes its value to Account receivable. Its not doing it, I also dont get any error notification. My guess is that I´m doing something wrong with setting the variables:
Option Explicit
Private Sub Leere()
Dim rng As range
Dim rcell As range
Dim WS As Worksheet
Set WS = Worksheets("Sheet2")
Set rng = WS.range("AK2", range("AK2").End(xlDown))
For Each rcell In rng
If rcell.Value = " " Then
rcell.Value = "Accounts Receivable"
End If
Next
End Sub
Any ideas?
use SpecialCells()
With ws
.Range("AK2", .Cells(.Rows.Count, "AK").End(xlUp)).SpecialCells(XlCellType.xlCellTypeBlanks).Value = "Accounts Receivable"
End With
You should be able to replace the empty (no formula) cells with something like this:
Set ws = ThisWorkbook.Worksheets("Sheet2")
Set rng = ws.Range("AK2", ws.Cells(ws.Rows.Count, "AK").End(xlUp))
rng.Replace "", "Accounts Receivable", xlWhole
Another non-VBA option can be Conditional Formatting for blank cells. The cell values will still be blank, but the displayed text change will be dynamic.
I'd like to create a macro that selects a rectangular range of cells and sets the name of every one of those cells to the value/contents of the cell.
In terms of what I've thought so far, I get an error though with the cell.Name line.
Public Sub NameCell()
Dim rng As Range
Dim cell As Range
Set rng = Range("A1:D1")
For Each cell In rng
cell.Name = CStr(cell.Value)
Next
End Sub
Is this what you meant?
Sub setVal()
Range("A1:C6").Select
Selection = "value"
End Sub
I believe this may work for you unless I also misunderstood the question.
Dim r As Range
Dim cell As Range
Set r = Sheet1.UsedRange
For Each cell In r
Sheet1.Names.Add Name:=cell.Value, RefersTo:=cell
Next
Keep in mind, though, that you would want to check that the cell.Value is valid (no spaces, etc.) for a named range.
To replace a range of cells with their values (removing any formulas from the range), you would use something like this.
Public Sub NameCell()
Dim rng As Range
Set rng = Range("A1:D1")
rng.Value = rng.Value
End Sub