vba excel - For Each cell In range - read comments - excel

there.
I'm trying to retrieve comments from a pre-defined name range of cells, but I keep getting the error message for the instruction: Set c = Range("myRange").Comment.Value
Only the active workbook is open, range is there, etc.
In the meantime, a value has been assigned to c, that corresponds to very first cell of myRange.
Any ideas? thanks a lot.
Sub Test_findComments_in_range()
Dim varComment As String
Dim c As Variant
With ActiveSheet
For Each c In .Range("myRange")
Set c = Range("myRange").Comment.Value
If IsEmpty(c) Then
MsgBox "No comment found! "
GoTo jumpCycle3
Else
varComment = c.Value
MsgBox varComment, vbInformation
End If
jumpCycle3: Next
End With
End Sub

There is no need to go through all the cells in the range and check each one for a comment, you can use the Range.SpecialCells method with the parameter xlCellTypeComments
Sub ListComments()
Dim rng As Range
Set rng = ActiveSheet.Range("myRange")
On Error GoTo out ' handle the error that occurs if there is no cell with comments
Set rng = rng.SpecialCells(xlCellTypeComments)
On Error GoTo 0
For Each cl In rng ' iterate over all cells in rng - each of them contains a comment
MsgBox cl.Address & " : " & cl.Comment.Text, vbInformation
Next
Exit Sub
out: MsgBox "No comments in the area"
End Sub

Find Comments in a Named Range
Option Explicit
Sub FindCommentsInNamedRange()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the named range ('rg').
Dim rg As Range: Set rg = wb.Names("myRange").RefersToRange
' To reference the range's worksheet (not necessary here), you could use:
'Dim ws As Worksheet: Set ws = rg.Worksheet
Dim cell As Range
Dim cm As Comment
Dim cText As String
' Loop through the cells of the range (note 'rg.Cells')...
For Each cell In rg.Cells
' Attempt to reference the cell's comment ('cm').
Set cm = cell.Comment
' Validate the comment.
If cm Is Nothing Then
MsgBox "No comment found!", vbExclamation, _
"Comment in Cell '" & cell.Address(0, 0) & "'"
Else
' Write the comment's text to a variable ('cText').
cText = cm.Text
MsgBox cText, vbInformation, _
"Comment in Cell '" & cell.Address(0, 0) & "'"
End If
Next cell
End Sub

Related

Printing Named Ranges by selecting from a list of named ranges

I have a worksheet that contains approx 50 Named Ranges and I create a list of those named Ranges which contain data and hence need to be printed. The names of those containing data are stored in a column. I need to use these names as Print Areas in a macro to loop through and print each of these ranges on a separate page. My problem is how to select each Cell Value to use as the name of a Print Area. Any assistance would be greatly appreciated
Print Named Ranges From a List
Option Explicit
Sub PrintNamedRangesFromList()
' Define constants.
Const SRC_WORKSHEET_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "A2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source single-column range (containing the names).
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_WORKSHEET_NAME)
Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_CELL)
Dim slCell As Range
Set slCell = sws.Cells(sws.Rows.Count, sfCell.Column).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
' For each cell of the source range, print the range
' defined by its name contained in the cell.
' Account for not existing names and names not referring to a range.
' Log the process ('Debug.Print') in the Immediate window (Ctrl+G).
Dim sCell As Range, prg As Range, pName As Name, pString As String
For Each sCell In srg.Cells
pString = CStr(sCell.Value)
On Error Resume Next ' prevent error if name not found
Set pName = wb.Names(pString)
On Error GoTo 0
If Not pName Is Nothing Then ' name found
On Error Resume Next ' prevent error if name not a range
Set prg = pName.RefersToRange
On Error GoTo 0
If Not prg Is Nothing Then ' name is a range
prg.PrintOut
Debug.Print "The range """ & pName.Name & """ referring to """ _
& pName.RefersTo & """ was processed."
Set prg = Nothing ' reset for the next iteration
Else ' name is not a range
Debug.Print "The name """ & pName.Name & """ refers to """ _
& pName.RefersTo & """ and was not processed."
End If
Set pName = Nothing ' reset for the next iteration
Else ' name not found
Debug.Print "The name """ & pString & """ was not found."
End If
Next sCell
' Inform.
MsgBox "Named ranges printed.", vbInformation
End Sub
Select the Cells and run this macro. It will loop through all the values and print the named ranges.
Sub printSelectedNamedRanges()
Dim rng as Range
set rng = Selection.Range
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub
You can add this on top of previous code if You have named ranges in another named Range.
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
Range(namedRange).Select
So in you case the code will be
Sub printSelectedNamedRanges()
Dim rng as Range
namedRange = "Put your main Named Range here "
sheetName = Range(namedRange).Parent.Name
ActiveWorkbook.Worksheets(sheetName).Activate
set rng = Range(namedRange)
For Each cell In rng.Cells
shName = Range(cell.Value).Parent.Name
ActiveWorkbook.Worksheets(shName).Activate
Range(cell.Value).PrintOut
Next
End Sub

VBA send cells value to another sheets next empty cell

I am trying to send a ticker from one workbook to another when ever it is one I would like to track. When I send it to the other workbook I want to paste the ticker in the next open cell in column JW.
So far my code is as follows:
Sub S2WL()
Dim lst As Long
Dim myVar As String
myVar = ActiveWorkbook.Activesheet.Range(“C2”).Value
With Workbooks("Dash").Sheet("DASH")
lst = .Range("JW" & Rows.Count).End(xlUp).Row + 1
.Range("JW" & lst).PasteSpecial xlPasteValues
End With
End Sub
I'm still very new to VBA and it fails when attempting to pull from my active sheet in workbook Fundamentals. I have multiple sheets that are basically copies in fundamentals. I want a general macro to send C2's value for whatever sheet I am on in Fundamentals to my watchlist in the Workbook Dash column JW. And each time to the next open cell in that column.
Thank you for any and all help!
Copy Value From the Active Sheet
A Qick Fix
Sub S2WLFixed()
Dim MyValue As Variant: MyValue = ThisWorkbook.ActiveSheet.Range("C2").Value
With Workbooks("Dash.xlsx").Worksheets("Dash")
Dim lst As Long: lst = .Cells(.Rows.Count, "JW").End(xlUp).Row + 1
.Cells(lst, "JW").Value = MyValue
End With
End Sub
An Improvement
The following covers most of the issues you may encounter when using the previous code.
Sub S2WL()
' 1. Define constants.
Const ProcName As String = "S2WL" ' for the message boxes
' s - Source (read from)
Const sCellAddress As String = "C2"
' d - Destination (write to)
Const dwbName As String = "Dash.xlsx" ' check if file extension is correct!
Const dwsName As String = "Dash"
Const dColumn As String = "JW"
' 2. Reference the source...
' Reference the workbook containing this code ('swb').
Dim swb As Workbook: Set swb = ThisWorkbook
' Reference the active sheet ('ash').
Dim ash As Object: Set ash = ActiveSheet
' Validate that the active sheet is in the source workbook.
If Not ash.Parent Is swb Then
MsgBox "The active sheet '" & ash.Name & "' is not located in the '" _
& swb.Name & "' workbook.", vbCritical, ProcName
Exit Sub
End If
' Validate that the active sheet is a worksheet.
If ash.Type <> xlWorksheet Then
MsgBox "The active sheet '" & ash.Name & "' is not a worksheet.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the source cell ('sCell').
Dim sCell As Range: Set sCell = ash.Range(sCellAddress)
' 3. Reference the destination...
' Validate the destination workbook ('dwb').
Dim dwb As Workbook
On Error Resume Next
Set dwb = Workbooks(dwbName)
On Error GoTo 0
If dwb Is Nothing Then
MsgBox "The destination workbook '" & dwbName & "' is not open.", _
vbCritical, ProcName
Exit Sub
End If
' Validate the destination worksheet ('dws').
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(dwsName)
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The destination worksheet '" & dwsName _
& "' does not exist in the '" & dwbName & "' workbook.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the destination cell ('dCell').
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
' 4. Copy.
' Write the value from the source cell to the destination cell.
dCell.Value = sCell.Value
' Save the destination workbook (decide on your own).
'dwb.Save
' 5. Inform.
MsgBox "Value copied.", vbInformation
End Sub

Execute Time (Select, Copy & Paste in same order for Non Adjacent Cells)

This VBA takes a lot of time to execute
Sub test()
Dim IB As String
Dim copyRng As Range, cel As Range, pasteRng As Range
With Selection
Set copyRng = Selection
End With
IB = Application.InputBox("Enter Exact Sheet Name to Paste")
Set pasteRng = Sheets(IB).Range("A1")
For Each cel In copyRng
cel.Copy
pasteRng.Range(cel.Address).PasteSpecial xlPasteAll
Next
Application.CutCopyMode = False
End Sub
Copy Non-Contiguous Ranges
I've turned off screen updating and replaced looping through cells with looping through areas of the range.
When you would only need values to be copied, another (vast) improvement in performance would be to copy by assignment. Then in the loop, you would use the following code:
darg.Value = sarg.Value
instead of sarg.Copy darg.
Option Explicit
Sub CopyNonContiguous()
Const ProcTitle As String = "Copy Non-Contiguous"
Dim srg As Range
If TypeName(Selection) = "Range" Then
Set srg = Selection
Else
MsgBox "Select a range. please.", vbCritical, ProcTitle
Exit Sub
End If
Dim wsName As Variant
wsName = Application.InputBox( _
"Enter Sheet Name to Paste", ProcTitle, , , , , , 2)
If wsName = False Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim dws As Worksheet
On Error Resume Next
Set dws = ActiveWorkbook.Worksheets(wsName) ' consider 'ThisWorkbook'
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The worksheet '" & wsName & "' doesn't exist.", _
vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
Dim sarg As Range
Dim darg As Range
For Each sarg In srg.Areas
Set darg = dws.Range(sarg.Address)
sarg.Copy darg
Next sarg
Application.ScreenUpdating = True
MsgBox "Cells copied.", vbInformation, ProcTitle
End Sub

Automatically update cells with dependent dropdown values

I have a sheet where there are two columns (Column C and column E). Column E has cells with dropdown menus that are dependent on the value of the cells in the same row, Column C.
I am trying to get the value in Column E to automatically change to the first option of the new corresponding dropdown menu when the value in Column C changes. As it stands, when the value in Column C changes, the value from before in the respective Column E cell remains, and I have to manually click and select from the new list.
Here is what I have to start:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng(1) As Range, rng1 As Range
Set rng(0) = Range("C71:C91")
Set rng(1) = Range("E71:E91")
Application.EnableEvents = False
If Not Intersect(Target, rng(0)) Is Nothing Then
For Each rng1 In rng(1)
i = i + 1
rng1 = Range("" & rng(0).Value2)(i, 1)
Next
End If
Application.EnableEvents = True
End Sub
Haven't fully tested the code, but can see a basic bug. Line:
For Each rng1 In rng(1)
Should read:
For Each rng1 In rng(1).Cells
Recalculate the sheet with Application.CalculateFull after your if statement.
A Worksheet Change with Data Validation (Drop-Downs)
It is assumed that the drop-downs in E71:E91 'get' the values from C71:C91 and that when you change (manually or via VBA) a value in C71:C91, the value in the same row of E71:E91 will be overwritten with this value.
Out-comment or delete the Debug.Print lines when done testing.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Debug.Print "Worksheet Change Sequence at " & Now
Debug.Print "1. '" & Target.Address(0, 0) & "' has changed."
Dim srg As Range: Set srg = Range("C71:C91")
Dim drg As Range: Set drg = Range("E71:E91")
Dim irg As Range: Set irg = Intersect(srg, Target)
Debug.Print "2. Range references created."
If irg Is Nothing Then
Debug.Print "3. No intersecting range. Exiting."
Exit Sub
Else
Debug.Print "3. Intersecting range at '" & irg.Address(0, 0) & "'."
End If
On Error GoTo ClearError
Application.EnableEvents = False
Debug.Print "4. Error handler activated. Events disabled."
' Write to intersecting rows only.
Dim dCol As Long: dCol = drg.Column
Dim iCell As Range
For Each iCell In irg.Cells
iCell.EntireRow.Columns(dCol).Value = iCell.Value
Next iCell
Debug.Print "5. Written to '" _
& Intersect(irg.EntireRow, drg).Address(0, 0) & "'."
'Or:
' Write to whole destination range.
'drg.Value = srg.Value
'Debug.Print "5. Written to '" & drg.Address(0, 0) & "'."
SafeExit:
Application.EnableEvents = True
Debug.Print "6. Events enabled. Exiting."
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
' Multi-range example. Best run from 'VBE' with the Immediate window open.
Sub Test()
Range("C71,C73,C75").Value = "A"
Range("C73,C75").Value = "B"
Range("C75").Value = "C"
End Sub

Show comments for each sheet of a workbook in a MsgBox

I am trying to display all comment text for each worksheet in the Activeworkbook in a MsgBox (for each comment).
My code isn't throwing an error, so I know I am close.
Sub ShowAllWorkbookcomments()
On Error Resume Next
Dim ws As Worksheet
Dim rng As Range
Dim cell As Variant
Dim cmt As String
Dim commentcount As Integer
Set ws = ActiveWorkbook.Worksheets(1)
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
commentcount = rng.Count
'cmt = ws.rng.Comment.Text
Dim varComment As String
Dim c As Comment
For Each ws In ActiveWorkbook.Worksheets
Select Case commentcount
Case 0
MsgBox "No Comment", vbExclamation
Resume Next
Case Is > 0
For Each cell In rng
varComment = c.Text
MsgBox varComment, vbInformation
Next cell
End Select
Set rng = Nothing
Next ws
End Sub
You were close, just needed to get the Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments) inside the For Each ws In ActiveWorkbook.Worksheets loop.
Also, added another way to trap the possibility of a worksheet having no comments, and removed the unnecessary Select Case.
Try the code below:
Option Explicit
Sub ShowAllWorkbookcomments()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim cmt As String
Dim varComment As String
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If Not rng Is Nothing Then '<-- current worksheet has comments
For Each cell In rng.Cells
'varComment = cell.Comment.text
varComment = "worksheet " & ws.Name & " comment " & cell.Comment.text ' <-- added the worksheet name as reference
MsgBox varComment, vbInformation
Next cell
Else '<-- current worksheet has No comments >> rng is Nothing
'MsgBox "No Comment", vbExclamation
MsgBox "worksheet " & ws.Name & " has No Comments", vbExclamation ' <-- added the worksheet name as reference
End If
Set rng = Nothing
Next ws
End Sub
As mentioned in one of the comments above, the above logic will cause the MsgBox to be shown for each of the cells in a merged range. The following logic will loop-through the comments in a given sheet, it will work for merged rows/cols scenario as well.
For Each CommentedSheets In ActiveWorkbook.Worksheets
If CommentedSheets.Comments.Count = 0 Then
MsgBox "worksheet " & CommentedSheets.Name & " has No Comments", vbExclamation
Else
For Each Individual_Comment In CommentedSheets.Comments
varComment = "worksheet " & CommentedSheets.Name & " comment " & Individual_Comment.text
MsgBox varComment, vbInformation

Resources