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
Related
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
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
I have a spreadsheet with two columns of data, both columns have a header. I would like to establish a variable for each row of data I can then use to generate new worksheet names and insert into formulas. My variable would be a one to one ratio with the data, meaning A2-B2, A3-B3, etc. I have tried the following code:
'''Sub CreateSheet2()
Dim rngBP As Range
Dim rngCon As Range
Dim cellBP As Range
Dim cellCon As Range
On Error GoTo Errorhandling
Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
Set rngCon = Application.InputBox(prompt:="Contractor Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
For Each cellBP In rngBP
If cellBP <> "" And cellCon <> "" Then
Sheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)).Name = cellBP & "-" & cellCon
End If
Next cellBP
Errorhandling:
MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
End Sub'''
However, this code generates a variable with all of the possible combinations (A2-B2, A2-B3, A3-B3, etc.). Ideally, this code would also skip empty cells and not create a variable for that entire row. Here is a screenshot of my sample dataset.Sample Dataset. Thank you for the assistance.
Add Worksheets with Names Created from Two Columns
I see the double Application.InputBoxes as a disaster waiting to happen so I abandoned the idea.
The code will search for the specified headers in the first row and their columns will define the column ranges (from the 2nd to the last row).
Copy the code into a standard module, e.g. Module1.
Adjust the four constants.
You only run the first procedure which will call the second when needed.
The third procedure is showing an example of proper error handling. Study it closely.
The Code
Option Explicit
Sub CreateSheet2()
'On Error GoTo ErrorHandling
Const wsName As String = "Sheet1"
Const bTitle As String = "Bid Package"
Const cTitle As String = "Contractor"
Const FirstRow As Long = 2
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim bCol As Variant
bCol = Application.Match(bTitle, ws.Rows(1), 0)
Dim cCol As Variant
cCol = Application.Match(cTitle, ws.Rows(1), 0)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, bCol).End(xlUp).Row
Dim ColumnOffset As Long
ColumnOffset = cCol - bCol
Dim SheetNames As Variant
SheetNames = getSheetNames(wb)
Dim rng As Range
Set rng = ws.Cells(FirstRow, bCol).Resize(LastRow - FirstRow + 1)
Dim cel As Range
Dim SheetName As String
For Each cel In rng.Cells
If cel.Value <> "" And cel.Offset(, ColumnOffset).Value <> "" Then
SheetName = cel.Value & "-" & cel.Offset(, ColumnOffset).Value
If IsError(Application.Match(SheetName, SheetNames, 0)) Then
On Error Resume Next
wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name _
= SheetName
If Err Then ' might happen if there are duplicates in columns.
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End If
On Error GoTo ErrorHandling
End If
End If
Next cel
ProcExit:
Exit Sub
ErrorHandling:
MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
& "': " & Err.Description, _
Buttons:=vbCritical, _
Title:="Fail"
Resume ProcExit
End Sub
Function getSheetNames(Book As Workbook) _
As Variant
If Book Is Nothing Then
GoTo ProcExit
End If
Dim Data As Variant
ReDim Data(1 To Book.Sheets.Count)
Dim sh As Object
Dim n As Long
For Each sh In Book.Sheets
n = n + 1
Data(n) = sh.Name
Next sh
getSheetNames = Data
ProcExit:
End Function
Proper Error Handling
Sub ProperErrorHandling()
On Error GoTo ErrorHandling
' The code
ProcExit:
Exit Sub ' You don't want to show the message if no error and
' you must not 'Resume' with no error!
ErrorHandling:
MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
& "': " & Err.Description, _
Buttons:=vbCritical, _
Title:="Fail"
' Sets the error number to 0, but still keeps the error handler active.
' Therefore be aware that if you put code between 'ProcExit' and 'Exit Sub'
' and an error occurs, it will result in an endless loop.
Resume ProcExit ' 'Resume', not 'GoTo'!
End Sub
Please try this code.
Sub CreateSheet2()
Const BidPack As String = "A" ' specify a column
Const Contractor As String = "B" ' change to suit (to the right of BidPack)
Const FirstDataRow As Long = 2 ' change to suit
Dim Wb As Workbook
Dim Ws As Worksheet
Dim BidRng As Range
Dim ConRng As Range
Dim Tmp As Variant ' misc use
Dim WsName As String
Dim R As Long ' loop counter: rows
Set Wb = ActiveWorkbook ' change to suit
WsName = "Sheet1" ' change to suit
Application.ScreenUpdating = False
Tmp = Columns(Contractor).Column
With Wb.Worksheets(WsName)
Set ConRng = .Range(.Cells(FirstDataRow, Tmp), _
.Cells(.Rows.Count, Tmp).End(xlUp))
' ConRng and BidRng are of identical size,
' not exceeding the number of rows available in ConRng.
Set BidRng = ConRng.Offset(, Columns(BidPack).Column - Tmp)
For R = 1 To BidRng.Cells.Count
If (Not IsEmpty(BidRng.Cells(R))) And (Not IsEmpty(ConRng.Cells(R))) Then
WsName = Format(BidRng.Cells(R).Value, "00-") & ConRng.Cells(R).Value
On Error Resume Next
Set Tmp = Wb.Sheets(WsName)
If Err Then
Wb.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count)).Name = WsName
Else
MsgBox "A worksheet by the name of """ & WsName & _
""" already exists.", vbInformation, _
"Duplicate instruction"
End If
End If
Next R
End With
Application.ScreenUpdating = False
End Sub
I think it's best
loop through rngBP range not empty values, only
using a Dictionary object to ensure you're not duplicating sheet names
Option Explicit
Sub CreateSheets()
Dim rngBP As Range
Dim cellBP As Range
On Error GoTo Errorhandling
Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
Dim shNamesDict As Object
Set shNamesDict = CreateObject("Scripting.Dictionary")
With ActiveWorkbook
Dim shName As String
For Each cellBP In rngBP.SpecialCells(xlCellTypeConstants)
If Not IsEmpty(cellBP.Offset(, 1).Value2) Then
shName = cellBP.Value2 & "-" & cellBP.Offset(, 1).Value2
If Not shNamesDict.exists(shName) Then
shNamesDict.Add shName, 0
.Sheets.Add(after:=.Worksheets(.Worksheets.Count)).Name = shName
End If
End If
Next
End With
Errorhandling:
If Err.Number <> 0 Then MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
End Sub
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
I want a VBA code by which I can check every cell in a range with a specific text?
EG: for each cell in range (a:a)
if value of cell = "specific text"
do this
else
do that
*
How to do this in VBA Excel?
here you go, but please try to find on google first
Sub eachCell()
Dim c As Range
For Each c In Range("A1:D21")
If (c.Value = "mytext") Then 'if value of cell = "specific text"
c.Value = "other text" 'do this
Else
c.Value = "other text 2" 'do that
End If
Next c
End Sub
Using a Find loop will be quicker than looking at each cell
Sub Sample_Find()
Dim rng1 As Range
Dim rng2 As Range
Dim bCell As Range
Dim ws As Worksheet
Dim SearchString As String
Dim FoundAt As String
Set ws = Worksheets(1)
Set rng1 = ws.Columns(1)
SearchString = "specific text"
Set rng2 = rng1.Find(SearchString, , xlValues, xlWhole)
If Not rng2 Is Nothing Then
Set bCell = rng2
FoundAt = rng2.Address
MsgBox "do something here " & FoundAt
Do
Set rng2 = rng1.FindNext(After:=rng2)
If Not rng2 Is Nothing Then
If rng2.Address = bCell.Address Then Exit Do
FoundAt = FoundAt & ", " & rng2.Address
MsgBox "do something here " & rng2.Address
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
Exit Sub
End If
MsgBox "The Search String has been found these locations: " & FoundAt
Exit Sub
End Sub
Another option to answer your post, using the AutoFilter.
Code
Option Explicit
Sub Test_AutoFilter()
Dim ws As Worksheet
Dim SearchString As String
Dim Rng As Range
Dim VisRng As Range
Dim c As Range
Set ws = Worksheets(1)
Set Rng = ws.Columns(1)
SearchString = "specific text"
Rng.AutoFilter
Rng.AutoFilter Field:=1, Criteria1:=SearchString
' set another range to only visible cells after the Filter was applied
Set VisRng = ws.Range(Cells(1, 1), Cells(1, 1).End(xlDown)).SpecialCells(xlCellTypeVisible)
If Not VisRng Is Nothing Then
' Option 1: show every cell that a SearchString was found
For Each c In VisRng
MsgBox "String match of " & SearchString & " found as cell " & c.Address
Next c
' Option 2: show all the cells that SearchString was found (in 1 message)
MsgBox "String match of " & SearchString & " found as cells " & VisRng.Address
End If
End Sub