I have two worksheets in the same workbook. The first worksheet contains last periods score matrix, the second worksheet contains this periods score matrix.
I am struggling to find a away to highlight those cells in this periods worksheet that are different from last periods worksheet.
I have been able to go as far as identifying the changed cells. I know that works from use of 'MsgBoxes', however I cannot find a way to highlight the identified cells. Its probably because I have chosen to go about this the wrong way entirely. Can someone please give me a guide as to how I should go about this?
The code I have that works (according to MsgBox's anyway) is below. I would very much appreciate any guidance whatsoever.
Thanks,
Option Explicit
Sub B_HighlightDifferences()
'Workbooks("Scoring Matrix NEW").Activate
Dim varScoring As Variant
Dim varScoring_OLD As Variant
Dim strRangeToCheck As String
Dim irow As Long
Dim icol As Long
Dim color As CellFormat
strRangeToCheck = "bl9:bo15" 'smallrange for testing purposes only
varScoring = Worksheets("Scoring").Range(strRangeToCheck)
varScoring_OLD = Worksheets("Scoring_OLD").Range(strRangeToCheck)
For irow = LBound(varScoring, 1) To UBound(varScoring, 1)
For icol = LBound(varScoring, 2) To UBound(varScoring, 2)
If varScoring(irow, icol) = varScoring_OLD(irow, icol) Then
' Cells are identical. ' Do nothing.
MsgBox "This has not changed"
Else
' Cells are different.
' Need code here to highlight each cell that is different
MsgBox "This has changed"
End If
End If
Next icol
Next irow
End Sub
You did most of the hard work. I would change the following. Add:
dim newCell as Range
Application.ScreenUpdating = False
... then inside your for loop:
Set newCell = varScoring.Cells(irow, icol)
Then you should be able to apply any formatting you want to newCell (which is a Range object) when you find it's different.
newCell.Select
With Selection.Interior
.Color = 49407
' any formatting you want.
End With
At the end of your routine, turn screen updating on again:
Application.ScreenUpdating = True
Let me know if this makes sense.
Related
VBA Hey guys, I just started to work with VBA and i am looking for a solution to my problem. The task is to count the number of different Values (Suppliers) inside a column, starting at a fixed point, lets say for column A to start at A5, but end at the last value in that column. Every time i try to put the range from A5 to last written cell in column A I either get errors or a wrong answer. Anyone here that can help me out?
Sub Count_Values_()
Sheets("Präsentation").Select
Dim dblAnz As Double
Dim rngRange As Range, rngRangeCnt As Range
Set rngRange = Range("A5:A50")
For Each rngRangeCnt In rngRange
dblAnz = dblAnz + 1 / WorksheetFunction.CountIf(rngRange, rngRangeCnt.Text)
Next
Dim Bereich As Range
Dim Zelle As Range
Dim lAnzahl As Long
Set Bereich = Range("A5:A50")
For Each Zelle In Bereich
If Zelle.Font.Bold = True Then
lAnzahl = lAnzahl + 1
End If
Next Zelle
Sheets("Anleitung").Select
Range("F1").Value = dblAnz - lAnzahl - 1
End Sub
This is the code I used before by searching values from A5 to A50 and subtracting all the bold headlines. I also added a -1 as an empty cell counts as a value as well I guess or at least I got the right numbers this way.
Please, try the next way:
Sub testCountDefinedRange()
Dim sh As Worksheet, startRow As Long
Const searchVal As Double = 25.13 'what is it to be searched for
Set sh = ActiveSheet 'use here the sheet you need
startRow = 5 'the starting row of the range to be searched
Debug.Print WorksheetFunction.CountIf(sh.Range("A" & startRow, sh.Range("A" & sh.rows.count).End(xlUp)), searchVal)
End Sub
But according to community spirit, you should prove your involvement in solving the problem by your own. Even if you cannot show us a working piece of code/formula etc. Anything proving that you did something, at least, some research on the internet...
I have a spreadsheet that a user enters/manages data in. They will insert rows, maybe copy rows and then input data.
There is a column, that holds MembID values, and the values for this are assigned when user clicks button to run a macro.
Every now and again the macro detects that it has duplicate values in the column and I am struggling to see how this could be possible and suspect that the user is manually entering values in the column.
I would like to be able to detect if they are entering data into a cell in that column. Any detection method needs to be able ignore changes made to the column by the macro! Is this possible to do?
I have managed to do 90+% of what I needed with the following code.....
Option Explicit
Public Sub Worksheet_Change(ByVal target As Range)
Dim intersection As Range
Dim ThisCell As String
Dim iRowFirst As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim sMessage As String
Dim iNoRows As Integer
Dim iMembColMembID As Integer
Dim iMembHeaderRow As Integer
' Find Column headings for "Membership" sheet
iMembHeaderRow = 1
Call FindHeader("Membership", iMembColMembID, iMembHeaderRow, "MembID")
Set intersection = Intersect(target, Range(Cells(1, iMembColMembID), Cells(2000, iMembColMembID)))
If Not intersection Is Nothing Then
iRowFirst = target.Row
iNoRows = target.Rows.Count
sMessage = ""
For iRow = iRowFirst To iRowFirst + iNoRows - 1
ThisCell = Cells(iRow, iMembColMembID)
If ThisCell <> "" Then
If sMessage = "" Then
sMessage = "The value for MembID has been changed for following row(s): "
End If
sMessage = sMessage & iRow & " "
End If
Next iRow
If sMessage <> "" Then
MsgBox sMessage
End If
End If
End Sub
I also put Application.EnableEvents.False at start of macro that adds new MembID values and then reenabled it at end of macro.
This detects the user adding data to the MembID column.
The only odd things are that if you copy/insert a number of rows then you will get 2 messages as the macro is triggered twice. Also, it will trigger if you delete a row.
But, in the grand scheme of things, then I can live with that!
So I've been having an issue with this script and was wondering if anyone could point me in the right direction to fix it.
I'm trying to scan a cell range and find the value of "X", which also has to align with the array (which seems to be working) that finds a value in another range of columns that is greater than 7.
Option Explicit
Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim Checks As Variant
Dim RiskName As Variant
Dim Level As Integer
Dim ThreatAgent As Variant
Dim Vulns As Variant
Dim X As Integer
Dim Y As Integer
Dim impactRange As Range
Dim impactCell As Range
Dim checksRange As Range
Dim checksCell As Range
Me.UsedRange.Offset(17).ClearContents
X = 2
Y = 1
With Sheets("TA & Vul Combinations")
.AutoFilterMode = False
Set impactRange = .Range("R3:R50")
For Each impactCell In impactRange.Cells
If impactCell.Cells > 7 And Not IsEmpty(impactCell.Cells) Then
impactCell.Copy
Sheets("temp").Range("B" & X).PasteSpecial xlPasteValues
X = X + 1
Else
End If
Next impactCell
Set checksRange = .Range("E3:E50")
For Each checksCell In checksRange.Cells
If checksCell.Cells("E3") = "X" Then
checksCell.Copy
Sheets("temp").Range("C2:AO2").PasteSpecial xlPasteValues
Else
Range("K1") = "You Broke It"
End If
Next checksCell
.AutoFilterMode = False
End With
End Sub
If anyone could give me some tips that would be great
This line is wrong:
If checksCell.Cells("E3") = "X" Then
since you are using Cells property incorrectly.
Cells property only accepts numeric arguments.
Syntax: Cells(rowindex,colindex)
Examples:
Cells(1,1) 'refers to Range("A1")
Cells(1) 'refers to Range("A1")
However, you can also use letters for Columns like this:
Cells(1,"A") 'refers to Range("A1")
Btw, this will work though.
If checksCell.Range("E3") = "X" Then
But take note of the implications.
When you use Range.Range syntax, what happens is that you use a Relative Reference on your first range.
Example1:
Range("B2").Range("E3").Address
will give you $F$4 because that is the 5th (E) column and 3rd (3) row from B2.
Other Examples:
Range("C1:E10").Range("B2").Address 'refers to $D$2
Range("C1:E10").Range("A1:B3").Address 'refers to $C$1:$D$3
Hope this clear things up a bit.
I don't know exactly what you want to achieve in your code, so I will not provide corrections.
I can only tell why you are getting errors.
If you need additional help, revise your question and clear major things up.
Re this line, which is probably the one where your error lies (it's the only if equals line in the code block):
If checksCell.Cells("E3") = "X" Then
I'm pretty certain checksCell is already a cell from doing a for each on the range checksRange, so I'm not sure that applying .Cells("E3") to it is the right thing to do, or even a sane thing to do :-)
I would think the correct way would be:
If checksCell.Value = "X" Then
I am trying to copy the value of multiple non-contiguous ranges into an array. I wrote code like this:
summaryTempArray = .range("A2:D9,A11:D12,A14:D15").Value
But it copies only the first part (A2:D9). Then, I tried the following and I get the error - "Method Union of Object _Global Failed" - is there any mistake in the way that I am using union?
summaryTempArray = Union(.range("A2:D9"), .range("A11:D12"), .range("A14:D15")).Value
Don't know what was wrong with your union, but it would have created the same range, which you stated in your first attempt.
The problem is, you have now multiple areas. Which you can, and as far as I know, has to address now.
Here is an example, which will resolve in an array of all areas, without adding each cell individually, but adding each area individually to the summary array:
Public Sub demo()
Dim summaryTempArray() As Variant
Dim i As Long
With Tabelle1
ReDim summaryTempArray(1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count)
For i = 1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count
summaryTempArray(i) = .Range("A2:D9,A11:D12,A14:D15").Areas(i)
Next i
End With
End Sub
Hope this helps.
I believe Jook's solution is as good as you are going to get if it is important to get the source ranges into an array. However, I think the solution should include instructions on extracting values from a ragged array. This is not difficult but the syntax is obscure.
I cannot get your Union statement to fail either. I assume there is something about the context that causes the failure which I cannot duplicate.
The code below shows that the two ranges are the same and that only the first sub-range is loaded to an array as you reported. It finishes with an alternative approach that might be satisfactory.
Option Explicit
Sub Test()
Dim CellValue() As Variant
Dim rng As Range
With Worksheets("Sheet1")
Set rng = .Range("A2:D9,A11:D12,A14:D15")
Debug.Print rng.Address
Set rng = Union(.Range("A2:D9"), .Range("A11:D12"), .Range("A14:D15"))
Debug.Print rng.Address
' The above debug statements show the two ranges are the same.
Debug.Print "Row count " & rng.Rows.Count
Debug.Print "Col count " & rng.Columns.Count
' These debug statements show that only the first sub-range is included the
' range counts.
CellValue = rng.Value
Debug.Print "Rows " & LBound(CellValue, 1) & " to " & UBound(CellValue, 1)
Debug.Print "Cols " & LBound(CellValue, 2) & " to " & UBound(CellValue, 2)
' As you reported only the first range is copied to the array.
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
' This shows you can copy the selected sub-ranges. If you can copy the
' required data straight to the desired destination, this might be a
' solution.
End With
End Sub
I had the same problem & tried a few methods without success until I hit on this:-
dim i as integer
Dim rng1 as range
Dim str as string
dim cels() as string
Set rng1 = sheet1.Range("A2:D9,A11:D12,A14:D15")
str = rng1.address(0,0)
cels() = split(str, ",") '<--- seems to work OK
for i = 0 to 2
Debug.Print cels(i)
Next i
I would be interested if this is an "incorrect" conversion method.
It is possible to create a multi dimensional array from non concurrent cell ranges. What I did was use a bit of the code above for the range copy mechanic I learned 2 things; that with that method you can refer to the actual cells and not just the data and you can also move and preserve order with it. In my personal project we have to use some excel files to fill out calibration data. It runs the calculations and produces a report of calibration record for our files to refer to later. These stock files are boring! I wanted to spruce it up a bit and color most of the documents empty cells depending on if the calibration passed or not. The files separate the individual check steps so the ranges I wanted to look through were not always adjacent. What I came up with is to use the copy function below to create a new sheet and paste all the non-concurrent ranges into one nice new set of concurrent ones and then have my array look at the new sheet to draw my table. I have it run the lookup I needed and then get rid of the now useless sheet.
Public Sub ColorMeCrazy()
' First Declare your variables that you will need line notes will be added to all the ones for just the array problem
Dim chkarray As Variant
Dim i As Integer ' for the array lookup loop
Dim j As Integer ' also for the array lookup loop
Dim chk1 As Boolean
Dim chk2 As Boolean
Dim cpyrange As Range ' the non-concurrent range collector haha.
Dim cz As Range
chk2 = True
Set cz = Worksheets("AN_PRM-36").Range("A1:I1,C2:I2,I3:I35,A30:H32,D33:H35,C34:C35,A36:E36,A22:H23,D24:H24,A16:H16,A8:H9,D10:H10")
' the next item below sets the ranges i wish to use. see that they arent all just right next to eachother.
Set cpyrange = Worksheets("AN_PRM-36").Range("G7:H7,G15:H15,G21:H21,G28:H29")
' this is the new sheet i made to create the array with
Sheets.Add.Name = "AN_PRM-36tmp"
' the data gets coppied to the new sheet but now its all together
cpyrange.Copy Destination:=Worksheets("AN_PRM-36tmp").Range("A1")
' now i tell the array i want it to use the data on the new sheet
chkarray = Worksheets("AN_PRM-36tmp").Range("A1:B5")
'this was my look up for the nonsense that i wanted to do later
For i = LBound(chkarray, 1) To UBound(chkarray, 1)
For j = LBound(chkarray, 2) To UBound(chkarray, 2)
Debug.Print chkarray(i, j)
If chkarray(i, j) = "Pass" Then
chk1 = True
Else
chk2 = False
End If
Next
Next
If chk1 = True And chk2 = True Then
cz.Interior.ColorIndex = 4
Else
cz.Interior.ColorIndex = 3
End If
' this last bit will get rid of the new sheet and not ask you are you sure you want it gone.
Application.DisplayAlerts = False
Sheets("AN_PRM-36tmp").Delete
Application.DisplayAlerts = True
End Sub
Here's what I need to do:
1) Loop through every cell in a worksheet
2) Make formatting changes (bold, etc) to fields relative to each field based on the value
What I mean is that if a field has a value of "foo", I want to make the field that is (-1, -3) from it bold, etc. I tried to do this with the following script with no luck.
Thanks
Johnny
Pseudo Code to Explain:
For Each Cell in WorkSheet
If Value of Cell is 'Subtotal'
Make the cell 2 cells to the left and 1 cell up from here bold and underlined
End If
End ForEach
The Failed Macro (I don't really know VB at all):
Sub Macro2()
'
'
'
Dim rnArea As Range
Dim rnCell As Range
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If Not IsError(rnCell.Value) Then
Select Case .Value
Case "000 Total"
ActiveCell.Offset(-1, -3).Select
ActiveCell.Font.Underline = XlUnderlineStyle.xlUnderlineStyleSingleAccounting
End Select
End If
End With
Next
End Sub
Option Explicit
Private Sub macro2()
Dim rnArea As Range
Dim rnCell As Range
' you might need to change the range to the cells/column you want to format e. g. "G1:G2000" '
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If isBold(.Offset(1, 3).Value) Then
.Font.Bold = True
End If
If isUnderlined(.Offset(1, 3).Value) Then
'maybe you want this: .Font.Underline = xlUnderlineStyleSingle '
.Font.Underline = xlUnderlineStyleSingleAccounting
End If
End With
Next
End Sub
Private Function isBold(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("Totals", "FooTotal", "SpamTotal")
listCount = 3
isBold = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isBold = True
Exit Function
End If
Next i
End Function
Private Function isUnderlined(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("FooTotal", "SpamTotal")
listCount = 2
isUnderlined = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isUnderlined = True
Exit Function
End If
Next i
End Function
I added two functions but it should have also worked with an extensive if / else if / else.
Based on the comments on the solution above, i think this might be helpful
Sub FormatSpecialCells()
Dim SearchRange As Range
Dim CriteriaRange As Range
Set SearchRange = Range("A2:A24")
Set CriteriaRange = Range("C2:C5")
Dim Cell As Range
For Each Cell In SearchRange
TryMatchValue Cell, CriteriaRange
Next
End Sub
Private Sub TryMatchValue(CellToTest As Range, CellsToSearch As Range)
Dim Cell As Range
For Each Cell In CellsToSearch
If Cell.Value = CellToTest.Value Then
Cell.Copy
CellToTest.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
End If
Next
End Sub
This does not fully accomplish your goal. What it does is it searches a specified list of cells, and it matches them against a seperate list of cells. If it matches the values, it takes the FORMAT of the second list of cells and applies it to the cell it matched in the first list of cells. You can modify this by changing the TryMatchValue function so that instead of matching the CellToTest, it pastes the format onto another cell which is 2 across and one up.
This has the advantage that, if you want to add more values and different formats, you only need to go to your excel sheet and add more values. Also you only need to change the format on that value.
An example would be...
Have the cells you are searching in A1:D1000
Have these values in cells E2:E6...
Subtotal (which is bold and underlined)
Total (which is bold, underlined and italic)
Net (which is bold underlined and Red)
etc...
then when it hits Subtotal, it will change the cell to be bold and underlined.
When it hits Total it will change the cell to be bold underlined and italic
etc etc...
hope this helps
Would the conditional formatting functionality in excel give you what you need without having to write a macro?