I'm using this code below to convert formula to cells, which works fine in a single sheet. But the problem is when I need to convert all selected cells which are in different sheets to their value, this code doesn't do it.
This is how I am selecting the cells in Excel:
first I select the cells in one sheet, than I go down to the tabs right-click and select specific sheets, which in Excel selects the corresponding cells in every selected sheet.
So any tips on how I can change this code to make it work across different sheets?
Sub formulaToValues()
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each cel In Selection.Cells
cel.Value = cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
End If
End Sub
You should be able to just grab the address of the selection, then add that to each worksheet's range
Sub formulaToValues()
Dim celAddr As String
celAddr = Selection.Address
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
With ws.Range(celAddr)
.Value = .Value
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
Next ws
End Sub
You are attempting to write to a 3D cell collection. An interesting problem i haven't seen before. I gave it a shot.
The below code works for me. I have simply added an extra loop to search through any other sheets. Note: it is good practice to always declare your variables.
Answer1: This cycles through every sheet in the workbook
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Worksheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Answer2: With this one it only goes throug the selected sheets
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Thanks alot guys, this got answered pretty quickly.
I am placing my macros in personal so I ended if with this
Sub formulaToValues3()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = ws.Range(cel.Address).Value 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Related
I have data such that single cells contain multiple bit of info.
Using conditional formatting excel can recognise cells which contain a phrase however the conditional format is applied to the cell as a whole. I'm aiming to try and Highlight the Specific text "Not Provided" in Red.
Looking online it looks like this will be a VBA solution.
To start, I have found the following code online however this doesnt appear to change the colour as desired.
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
strString = Range("B1").Value
Application.ScreenUpdating = False
For Each rngCell In Range("G1", Range("G" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
If someone could point out either how I can get the code above working to explore if this will be useful for my purposes or even if someone knows how to conditionally format specific words that would be great. Ultimately I wish for every instance of "Not Provided" across the worksheet to be highlighted in this way.
You can use InStr() to find substring instead of For loop
Sub Test1()
Dim strString As String, x As Long, rngCell As Range
strString = Range("B1").Value
Application.ScreenUpdating = False
For Each rngCell In Range("G1", Range("G" & Rows.Count).End(xlUp))
x = InStr(1, rngCell.Value2, strString, vbTextCompare)
If x > 0 Then
With rngCell
.Font.ColorIndex = 1
.Characters(x, Len(strString)).Font.ColorIndex = 3 'red color
End With
End If
Next
Application.ScreenUpdating = True
End Sub
To dynamically change the color of the text, as in conditional formatting, you can use the Change event:
'place it into the Worksheet module
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strString As String, x As Long, rngCell As Range, rng As Range
Set rng = Intersect(Target, Me.Columns("G"))
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
strString = Range("B1").Value
For Each rngCell In rng
x = InStr(1, rngCell.Value2, strString, vbTextCompare)
If x > 0 Then
With rngCell
.Font.ColorIndex = 1
.Characters(x, Len(strString)).Font.ColorIndex = 3 'red color
End With
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I'm new to VBA and wrote the following codes according to my data set. The goal here is to execute my procedure if a cell/range gets changed by pasting new data into the worksheet, most probably the sheet will be empty as it will follow by a clear content procedure.
However, the code is not triggering the change event, I've tried several codes from Google, but none of them worked. Please note that my procedure gets me exactly the data I want in the format I want, however, if changes are needed, kindly let me know.
PLEASE HELP
1. Change event trigger - stored under Sheet1
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A1")) Is Nothing Then
Application.EnableEvents = False
Call LoopandIfStatement
Application.EnableEvents = True
End If
End Sub
2. My procedure - stored under Sheet1 below the event above
Sub LoopandIfStatement()
Dim SHT As Worksheet
Set SHT = ThisWorkbook.Worksheets("CB")
MyLr = SHT.Cells(Rows.Count, 1).End(xlUp).Row
Dim I As Long
For I = 1 To MyLr
Dim O As Long
Dim U As Range
Set U = SHT.Range("A" & I)
If IsEmpty(SHT.Range("a" & I).Value) = False Then
SHT.Range("k" & I).Value = SHT.Range("A" & I).Value
Else
On Error GoTo ABC
SHT.Range("k" & I).Value = U.Offset(-1, 0)
End If
Next I
For O = 2 To MyLr
If SHT.Range("g" & O).Value = "Closing Balance" Then
SHT.Range("l" & O).Value = SHT.Range("j" & O).Value
End If
Next O
ABC:
End Sub
Results
This will trigger whenever new data is pasted in any cell of columns A to J
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A:J")) Is Nothing Then
Application.EnableEvents = False
Call LoopandIfStatement
Application.EnableEvents = True
End If
End Sub
Regarding your sub LoopandIfStatement here are some suggestions:
Use Option explicit at the top of your modules (see this)
Declare all your variables (you're missing: Dim MyLr as long)
Try to name your variables to something understandable (e.g. instead of MyLr you could have lastRow)
If you need to exit a Sub you can use Exit Sub instead of a Goto ABC
EDIT:
Added code for the loop and the change worksheet event.
Paste it behind the CB Sheet module
Some highlights:
When you triggered the loop on each worksheet change, it would re-apply all the steps to all the cells. You can work with changed ranges using the Target argument/variable in the Worksheet_Change event
To loop through an existing range see the AddAccountBalanceToRange procedure
Try to think and plan your code in steps or actions that can be grouped
Use comments to describe the purpose of what you're doing
Remember to delete obsolete code (saw you had a copy of the procedure in a module)
Option Explicit
Private Sub CommandButton1_Click()
ThisWorkbook.Worksheets("Data").Columns("A:J").Copy
ThisWorkbook.Worksheets("CB").Range("A:J").PasteSpecial Paste:=xlPasteValues
End Sub
Private Sub CommandButton2_Click()
ThisWorkbook.Worksheets("CB").Range("A:L").ClearContents
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetUsedRange As Range
' Do something on non empty cells
Set targetUsedRange = Intersect(Target, Target.Parent.UsedRange)
If Not Intersect(Target, Me.Range("A:J")) Is Nothing Then
Application.EnableEvents = False
Call AddAccountBalance(targetUsedRange)
Application.EnableEvents = True
End If
End Sub
Private Sub AddAccountBalance(ByVal Target As Range)
Dim targetSheet As Worksheet
Dim evalRow As Range
Dim lastColumn As Long
Dim accountNumber As String
Dim balanceString As String
Dim narrative As String
Dim balanceValue As Long
balanceString = "Closing Balance"
' If deleting or clearing columns
If Target Is Nothing Then Exit Sub
' Do something if there are any values in range
If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub
' Get the parent sheet of the cells that were modifid
Set targetSheet = Target.Parent
' Get the last empty cell column in row 1 -Cells(3 -> this is row 3)- In the sample book: column K
lastColumn = targetSheet.Cells(3, targetSheet.Columns.Count).End(xlToLeft).Column
' Loop through each of the rows that were modified in range
For Each evalRow In Target.Cells.Rows
' Do something if account number or narrative are not null
If targetSheet.Cells(evalRow.Row, 1).Value <> vbNullString Or targetSheet.Cells(evalRow.Row, 7).Value <> vbNullString Then
' Store columns values in evaluated row
accountNumber = targetSheet.Cells(evalRow.Row, 1).Value
narrative = targetSheet.Cells(evalRow.Row, 7).Value
If IsNumeric(targetSheet.Cells(evalRow.Row, 10).Value) Then balanceValue = targetSheet.Cells(evalRow.Row, 10).Value
' Add account number
If accountNumber <> vbNullString Then
targetSheet.Cells(evalRow.Row, lastColumn).Value = accountNumber
End If
' Add closing balance
If narrative = balanceString Then
targetSheet.Cells(evalRow.Row, lastColumn).Value = targetSheet.Cells(evalRow.Row, 1).Offset(-1, 0).Value
targetSheet.Cells(evalRow.Row, lastColumn).Offset(0, 1).Value = balanceValue
End If
' Format last two columns (see how the resize property takes a single cell and expands the range)
With targetSheet.Cells(evalRow.Row, lastColumn).Resize(, 2).Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Auto fit last column (K) (you could use the resize property as in the previous statement)
targetSheet.Columns(lastColumn).EntireColumn.AutoFit
End If
Next evalRow
End Sub
Public Sub AddAccountBalanceToRange()
Dim targetSheet As Worksheet
Dim evalRange As Range
Set targetSheet = ThisWorkbook.Worksheets("CB")
Set evalRange = targetSheet.Range("A1:A42")
AddAccountBalance evalRange
End Sub
I want to highlight and count the number of duplicates in a single concatenated column.
I have it as two separate subs right now and there really isn't much more to say, this isn't that hard of a problem I'm confident of that but I have been working on it for days with absolutely no progress. It has to be done in a VBA and it cannot highlight blank cells in the column. The concatenations are done through a formula in the workbook. Please help me, I m dying,
Sub Duplicate_Check()
Dim ws As Worksheet
Set ws = Sheet1
Worksheets("Master Checklist").Activate
Columns("H:H").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.ColorIndex = 40
.TintAndShade = 0
End With
'Sheet2.Range(“L2").Value = Application.WorksheetFunction.Countif(Columns("H:H")), cell.Font.Color = "-16383844")
'Range(“B10?).Value = Application.WorksheetFunction.Countif(Range(“A2:A8?), “>” & 50
End Sub
Sub CountDupes()
Dim countofDupes As Long
Dim rng As Range
Dim myCell As Range
countofDupes = 0
Set rng = Range("H2").End(xlDown)
For Each myCell In rng
If myCell.Interior.ColorIndex = 40 Then
countofDupes = countofDupes + 1
Debug.Print countofDupes
End If
Next myCell
End Sub
I don't encounter any error messages but if I Debug.Print countofDupes I get nothing returned, which it obviously not what I want. Any advice?
I have a template where the user enters account information and the default range for information is range B18 to S52. This fits nicely onto the screen and is a big enough range for the details being entered 90% of the time. However on a few occasions the use may have data that is a few hundred rows. Its usally copied and pasted in but would make the sheet look messy as it would be out of the default range.
I'm trying make the formatting dynamic where by if the user enters data outside of the default range a macro is triggered that will count the rows and reformat the range.
The code I have so far from researching online is:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$18" Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
With Application
.DisplayAlerts = False
'.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
End With
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Range("B1048576").End(xlUp).row - 17
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(17 + LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 1 To LocCount Step 2
Rows(18 + i).EntireRow.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
This essentially colors every other row light blue and white and adds a border to each cell. The Count Loc works fine and does what I need it to do but the problem I have is that I cannot get the worksheet_Change to trigger.
Thanks in advance
there
I ran a little test using your code and the first thing I noticed, is that you set the Application.EnableEvents to False and you don't set it back on, so you are cancelling any event like the Worksheet_Change Event once that's fix the event will trigger any time the cell B18 changes, except if the value that is entered comes from a paste(not sure why) but if you use the Intersect method then it works even if the value came from a copy paste.
I did some small tweeks to your code and I think it works now. please review it and give it a try.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ThisWorkbook.Sheets("Account Input").Range("B18")) Is Nothing Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 18 To LocCount Step 2
Set rng = WsInput.Range(WsInput.Cells(i, 2), WsInput.Cells(i, 19))
rng.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
End Sub
I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.
Performance
1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.
It is better to Union all the cells to be merged and merge them in a single operation.
Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array.
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.
It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.
I suggest the following, where you just iterate through the columns, and then through the cells in each column:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.
I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References:
Excel object model
Global Sheets property, Sheets collection
Worksheet object
UsedRange property
Range object
Cells property
Row property
Offset property
MergeArea property
Value property
VBA
For Each ... In construct
IsEmpty function
Dim statement
Set statement
Sub statement