I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub
Related
Is there a way to identify if a worksheet has a highlighted cell at a worksheet level, without checking all the cells?
Further context:
I have a WorkBook with a number of Worksheets(ws).
some of the worksheets have cells that are highlighted.
I want to be able to take out the worksheets that have a cell highlighted and put them in another workbook.
But the way I do it is, I go through each cell in each worksheet to find a highlighted cell, and when I find one, I copy this worksheet to another workbook and move on to the next work sheet.
But the more ws there are the longer this takes and because I have to go through individual cells.
So my questions is, Is there a way to identify if a worksheet has a highlighted cell at a worksheet level? Or do I have to go through each cell range in each worksheet?
Code
' copy the path from cell a1 to the master in a1, a2, a3.....
' want to add to copy the WS if it has a highlighted area
' added copy ws with highlight to new WB and exit for loop for checking more highlighted areas
' this works C:\Samsung\Macros\test_macro_test3.xlsm, see cloumn A in master sheet and have Summary.xlsm WB open
Sub test3()
Dim startTime, endTime As Date
startTime = Now
Dim ws As Worksheet, MainWs As Worksheet, cell As Range
Set MainWs = Sheets("master") '<-- change name as needed
Dim i As Integer
i = 1
For Each ws In Sheets
If ws.Name <> MainWs.Name Then
For Each cell In ws.UsedRange
Debug.Print "ws.Name:" & ws.Name
Debug.Print "cell.Address:" & cell.Address
Debug.Print "cell.Value:" & cell.Value
Debug.Print "i:" & i
'if your cells are colored through conditional formatting, delete/comment below line & uncomment the line after
If cell.Interior.Color = vbYellow Then
MainWs.Range("A" & i) = ws.Range("A1").Value
MainWs.Range("B" & i) = ws.Name
ws.Copy After:=Workbooks("Summary.xlsm").Sheets(Workbooks("Summary.xlsm").Sheets.Count)
Exit For
'If cell.DisplayFormat.Interior.Color = vbYellow Then MainWs.Range(cell.Address) = cell.Value
Debug.Print "cell.Address:" & cell.Address
Debug.Print "cell.Value:" & cell.Value
Debug.Print "i:" & i
Exit For
End If
Next
End If
i = i + 1
Next 'next worksheet
endTime = Now
Debug.Print "startTime:" & startTime
Debug.Print "endTime: " & endTime
Debug.Print "Total(hh:mm:ss)" & Format((DateDiff("s", startTime, endTime)) / 86400, "hh:mm:ss")
End Sub
WB examples
https://www.dropbox.com/scl/fi/7x91vwbvv62nn15loczpy/test_macro_test3.xlsm?dl=0&rlkey=k8b53wizejaf4jqwjzilthvg2
https://www.dropbox.com/scl/fi/8c5uatqyhlwlv5pzcude7/Summary.xlsm?dl=0&rlkey=fodf1j7ic7ac5pl9coehnlhab
You can use the following function to check if a worksheet has cells with a certain background color:
Public Function hasSheetHighlightedCells(ws As Worksheet, _
Optional lngColor As Long = vbYellow) As Boolean
Application.FindFormat.Clear
Application.FindFormat.Interior.color = lngColor
Dim rgFound As Range
On Error Resume Next 'in case nothing can be found
Set rgFound = ws.UsedRange.Find("*", searchFormat:=True)
On Error GoTo 0
If Not rgFound Is Nothing Then
hasSheetHighlightedCells = True
End If
Application.FindFormat.Clear
End Function
You will call that function within your For each ws in Sheets loop:
If hasSheetHighlightedCells(ws) = true then
This will check for the default color vbYellow.
If you want to check for a different color you can use e.g.
If hasSheetHighlightedCells(ws, vbRed) = true then
I have a list of names in a row, A2 to AAS2, I also have a drop-down list containing all of those names. I would like some VBA code that when the list is changed excel jumps to the cell matching the item in the list. Could someone please help me with this? Thank you.
The names are just text, no named ranges.
Here is what I have tried so far:
Private Sub FindTicker()
Dim MyVariable As String
MyVariable = Range("L1").Value
Application.Goto Reference:=Range(MyVariable)
End Sub
And Also
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> [L1].Address Then
Exit Sub
Else
JumpToCell
End If
End Sub
Sub JumpToCell()
Dim xRg, yRg As Range
Dim strAddress As String
strAddress = ""
Set yRg = Range("A2:AAS2")
For Each xRg In yRg
'MsgBox Cell.Value
If xRg.Value = ActiveCell.Value Then
strAddress = xRg.Address
End If
Next
If strAddress = "" Then
MsgBox "The Day You Selected in Cell D4 Was Not Found On " & ActiveSheet.Name, _
vbInformation, "Ticker Finder"
Exit Sub
Else
Range(strAddress).Offset(0, 1).Select
End If
End Sub
When I tried using both of these when I changed the drop-down list nothing happened. No errors or anything.
Lots of ways to do this and with some tweaks your code above could work but its a bit inefficient and more complicated than it needs to be. The simplest way would be to use the Find method of the Range class to locate the cell:
Lets say your drop-down list of names is in cell A1 on sheet MySheet and the long list is in column C. Use the Find method to set a range variable to equal the first cell containing the item in cell A1.
Dim rng As Range
Dim ws As Worksheet
Set ws = Sheets("MySheet")
Set rng = ws.Range("C:C").Cells.Find(ws.Range("A1"), lookat:=xlWhole)
If Not rng Is Nothing Then ' the item was found
rng.Select
Else
MsgBox "This item is not in the list", vbInformation
End If
I have a source workbook and a destination workbook. The source book has a range (D13:F293) that contains data values, as well as blank cells. The destination book contains the same range and various cells contain formulas.
I want to import data from the source book to the destination book, but ONLY cells that contain a value. Furthermore, if the destination book/cell contains a formula, I want to KEEP the formula in the cell.
My options are:
Scan the source for blank cells and only import cells with data.
Scan the destination for formulas, and if a formulas exists, don't import data to that cell.
I don't know how to do this. I am very new to VBA and don't fully understand the syntax. I have tried 3 times with code that either replaces formulas with blank cells, or gives an error.
This code copies blank cells to destination book:
Sub TransferData()
If Workbooks.Count > 1 Then
Workbooks(2).Sheets("HELOC").Range("D13:F293").Copy
Workbooks(1).Sheets("HELOC").Range("D13:F293").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(2).Close savechanges:=False
Else
MsgBox "The data hasn't been transferred.", vbExclamation, "Error"
End If
End Sub
This code also copies blank cells to destination book:
Sub TransferData()
If Workbooks.Count > 1 Then
For Each cl In ActiveSheet.UsedRange
If cl.HasFormula() = True Then
Workbooks(1).Sheets("HELOC").Range("D13:F293") = Workbooks(1).Sheets("HELOC").Range("D13:F293")
Else
Workbooks(1).Sheets("HELOC").Range("D13:F293").Value = Workbooks(2).Sheets("HELOC").Range("D13:F293").Value
End If
Next cl
Workbooks(2).Close savechanges:=False
Else
MsgBox "The data hasn’t been transferred.", vbExclamation, "Error"
End If
End Sub
This code (modified from here) results in:
Runtime error 91
Object variable or With block variable not set on line:
"If mySourceBook.Cells(i, 1).Value <> "" Then"
Sub TransferData()
Dim mySourceBook As Worksheet, myDestinationBook As Worksheet, myBook As Workbook
Set myBook = Excel.ActiveWorkbook
Set mySource = myBook.Sheets("HELOC")
Set myImportData = Excel.ActiveWorkbook.Sheets("HELOC")
Dim i As Integer, j As Integer 'Define a couple integer variables for counting
j = 13
For i = 13 To 293
If mySourceBook.Cells(i, 1).Value <> "" Then
myDestinationBook.Cells(j, 2).Value = mySourceBook.Cells(i, 1).Value
j = j + 1
End If
Next i 'This triggers the end of the loop and moves on to the next value of "i".
Workbooks(2).Close savechanges:=False
MsgBox "The data hasn’t been transferred.", vbExclamation, "Error"
End Sub
I appreciate any advice given. But please, explain it to me like I'm a child as I don't fully comprehend VBA.
You can do it like this:
Sub MoveIt()
Dim rngSrc As Range, rngDest As Range, i As Long, cS As Range, cD As Range
Set rngSrc = Workbooks("Source.xlsx").Worksheets("Sheet1").Range("D13:F293")
Set rngDest = Workbooks("Target.xlsx").Worksheets("Sheet4").Range("D13:F293")
For i = 1 To rngSrc.Cells.Count
Set cS = rngSrc.Cells(i)
Set cD = rngDest.Cells(i)
If Len(cS.Value) > 0 And Not cD.HasFormula Then
cS.Copy cD
'or
cD.Value = cS.Value
End If
Next i
End Sub
I got it to work how I want! Thank you very much for your help, Tim!
Now to figure out how to import and keep the format.
Sub TransferData()
Dim rngSrc As Range, rngDest As Range, i As Long, cS As Range, cD As Range
Set rngSrc = Workbooks("Exported AMP Data.xlsx").Worksheets("HELOC").Range("D13:F293")
Set rngDest = Workbooks(1).Worksheets("HELOC").Range("D13:F293")
For i = 1 To rngSrc.Cells.Count
Set cS = rngSrc.Cells(i)
Set cD = rngDest.Cells(i)
If Len(cS.Value) > 0 Then
cS.Copy cD
'or
cD.Value = cD.Value
End If
Next i
End If
End Sub
I am new in VBA and I want to write a program that when I manually select 1 or more items from a list the code searches with the name of the item and picks it from another sheet, copies the whole row and pastes it in a 3rd sheet. Is that possible? Preferably with a click of a button the selection is made. Thanks a lot!
Here is an example.
Sub FindAndMove()
Dim Finder As Range
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
.Select 'Optional - show sheet 3
End With
End With
End Sub
Walking through the code:
When they click the button, if they only select 1 cell that's in our list.
Get the value of the item they selected
On Sheet2 - go find that value in column A
If you find it, copy the entire row to the end of Sheet3
You can modify the code by changing the sheet names in Sheet("Sheet1") to whatever you want.
You can also change the list range by changing .Range("A2:A11")
You can change the range to search by changing .Range("A:A")
Sheet 1:
Sheet 2:
Sheet 3: (after we select item 3 and click Find and Move)
Error Handling:
Edit:
Code to find multiple occurrences using FindNext
Sub FindAndMove()
Dim Finder As Range
Dim FirstAddress As Variant
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
FirstAddress = Finder.Address
Do
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
End With
Set Finder = .Range("A:A").FindNext(Finder)
Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End With
Sheets("Sheet3").Select 'Optional - Select Sheet3 After.
End Sub
My code is not working properly. It's only showing the first empty cell T10 but cells from T10 to T15 are all empty. I would also like to identify cells that are showing #REF! in them. I don't need the address of empty cells (as there could be quite a few on bigger scale) but would like to know the address of cells with #REF! Thank you!
Sub Identiycells()
Dim Cancel As Boolean
Dim cell As Range
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets(Array("a", "b"))
For Each cell In sh.Range("T6:T18")
If IsEmpty(cell) 'Or showing #REF! Then
MsgBox "Data Missing or Formula error" & cell.Address
Application.Goto cell, True
Cancel = True
Exit For
End If
Next cell
Next sh
End Sub
You could collect the errors in a String and only report once at the end. For checking #REF or other errors you can test with IsError(cell.value).
As you are going through different sheets, it might be good to specify which sheet the cells are on. You can get a cell reference including its sheet with Split(cell.address(External:=True), "]")(1).
Suggested code:
Sub Identiycells()
Dim Cancel As Boolean
Dim cell As Range
Dim sh As Worksheet
Dim report as String ' collect all errors
Dim errorMsg as String ' error for current cell
Dim errorCell as Range ' cell to focus at the end
For Each sh In ThisWorkbook.Worksheets(Array("a", "b"))
For Each cell In sh.Range("T6:T18")
errorMsg = ""
If IsEmpty(cell) Then
errorMsg = "Data Missing"
If errorCell Is Nothing Then Set errorCell = cell
ElseIf IsError(cell.value) Then
errorMsg = "Invalid Reference"
Set errorCell = cell
End If
If errorMsg <> "" Then
report = report & errorMsg & " in " & _
Split(cell.address(External:=True), "]")(1) & vbCrLf
End If
Next cell
Next sh
If Not errorCell Is Nothing Then
MsgBox report
Application.Goto errorCell, True
Cancel = True
End If
End Sub