I have a worksheet with many duplicated Conditional Formatting instances.
I'm trying to write code to tidy/delete many of them.
I need to modify the Format Condition.
Any idea why the following doesn't work?
Sub UpdateCondition(ByRef bFirst As Boolean, rng As Range, f As FormatCondition, replacementFormula As String)
If bFirst Then
f.Modify f.Type, , replacementFormula
f.ModifyAppliesToRange rng
bFirst = False
Else
f.Delete
End If
End Sub
I get the following error:
Method 'ModifyAppliesToRange' of object 'FormatCondition' failed
This code works for many of my conditions. Only some of them trip up.
-- edit --
My calling code is as follows
Dim f As FormatCondition
Dim bFirst As Boolean
Dim i As Integer
Set rng = SomeRangeOnTheSheet
bFirst = True
For i = ActiveSheet.Range(Cells.Address).FormatConditions.Count To 1 Step -1
Set f = ws.Range(Cells.Address).FormatConditions(i)
If f.Formula1 = "..Some Formula.." Then
UpdateCondition bFirst, rng, f, replacementFormula
End If
Next
-- edit --
Function SomeRangeOnTheSheet() As Range
Dim cell1 As Range
Dim cell2 As Range
Set cell1 = Cells(Range("Roster").row, Range("StartDate").Column)
Set cell2 = Cells(Range("Roster").row + Range("Roster").Rows.Count - 1, Range("Roster").Column + Range("Roster").Columns.Count - 1)
Set RosterDataRange = Range(cell1, cell2)
End Function
Related
I have an input table in range A2: D6, I want each value in input range to be shown 4 times in output
range A8: D27
Below is the code it is copying only one value to the output range.
Could you please guide me on how to change this VBA code to get the desired result as shown in the below picture.
Sub RepeatData()
Dim Rng As Range
Dim lr As Integer
Dim C As Integer
Range(("A8"), Range("D10000")).ClearContents
lr = Range(("A1"), Range("A2").End(xlDown)).Count
C = 4
Dim InputRng As Range, OutRng As Range
Set InputRng = Range("A2", Range("d" & lr))
Set OutRng = Range("a8")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1", "a1").Value
xNum = 4 ' No. of times to repeat
OutRng.Resize(xNum, C).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next
End Sub
I can see that you are looping through entire input rows, so I would propose a solution copying entire rows.
Sub RepeatData()
Dim inputWorksheet As Worksheet
Dim inputRange As Range
Dim outputRangeStart As Range
Dim rowToBeCopied As Range
Dim firstFreeRow As Range
Dim numberOfOutputRows As Integer
Dim outputRange As Range
' set all params
Set inputWorksheet = Sheet1
Set inputRange = inputWorksheet.Range("A2:D5")
Set outputRangeStart = inputWorksheet.Range("A8")
numberOfOutputRows = 4
' clean output range
Range(outputRangeStart, outputRangeStart.End(xlDown).End(xlToRight)).ClearContents
' copy values
For Each rowToBeCopied In inputRange.Rows
Set firstFreeRow = FindFirstFreeCell(outputRangeStart)
Set outputRange = ExtendRangeByNumberOfRows(firstFreeRow, numberOfOutputRows)
rowToBeCopied.Copy
outputRange.PasteSpecial xlPasteValues
Next rowToBeCopied
End Sub
Function FindFirstFreeCell(startFrom As Range) As Range
If IsEmpty(startFrom) Then
Set FindFirstFreeCell = startFrom
ElseIf IsEmpty(startFrom.Offset(1, 0)) Then
Set FindFirstFreeCell = startFrom.Offset(1, 0)
Else
Set FindFirstFreeCell = startFrom.End(xlDown).Offset(1, 0)
End If
End Function
Function ExtendRangeByNumberOfRows(rangeToBeExtended As Range, numberOfRows As Integer) As Range
Set ExtendRangeByNumberOfRows = Range(rangeToBeExtended, rangeToBeExtended.Offset(numberOfRows - 1, 0))
End Function
In my code I use two instances of .Find, combined with a .FindNext. Which is notoriously prone to errors, unfortunately I'm no exception. However this is the best I could come up with. Code below, where I stripped most irrelevant stuff.
The problem is that there are duplicate values, which I want to keep both, so I decided to use .Findnext if there is a duplicate, using:
If newqst = refqst Then
Set newqstadrs = Findrange.FindNext(after:=lstqstadrs)
Else
The problem here is that .FindNext doesn't respect that it should continue on the Findrange.Find, but continues on the FindRangeTwo.Find used here:
newrowtwo = FindRangeTwo.Find(rCell.Value, LookIn:=xlValues, lookat:=xlWhole).row
Full Code:
For o = 72 To lastrow
Dim refqst As String
refqst = wss.Cells(o, 1).Value
If Not refqst = "" Then
If InStr(refqst, ".") > 0 Then
Dim Findrange As Range
Dim newqst As String
Dim newqstadrs As Range
Dim lstqstadrs As Range
If newqst = refqst Then
Set newqstadrs = Findrange.FindNext(after:=lstqstadrs)
Else
Select Case Left(refqst, 1)
Case 1
Set Findrange = wsa.Range(wsa.Cells(4, gewaskolom), wsa.Cells(11, gewaskolom))
'some more cases here
End Select
Set newqstadrs = Findrange.Find(refqst, LookIn:=xlValues, lookat:=xlWhole)
End If
If newqstadrs Is Nothing Then
Else
newqst = newqstadrs.Value
Dim newrow As Long
newrow = Findrange.Find(refqst, LookIn:=xlValues, lookat:=xlWhole).row
Dim lstqst As String
If Not wsa.Cells(newrow, 1) = "" Then
'do some stuff
lstqst = refqst
Set lstqstadrs = newqstadrs
ElseIf Not wsa.Cells(newrow, 2) = "" Then
Dim FindRangeTwo As Range
Set FindRangeTwo = wsa.Range(wsa.Cells(newrow, gewaskolom), wsa.Cells(wsa.Range("B" & newrow).End(xlDown).row, gewaskolom))
Dim SearchRange As Range
Set SearchRange = wss.Range(wss.Cells(o + 1, 1), wss.Cells(wss.Range("B" & o).End(xlDown).row, 1))
Dim rCell As Range
For Each rCell In SearchRange
Dim newrowtwo As Long
newrowtwo = FindRangeTwo.Find(rCell.Value, LookIn:=xlValues, lookat:=xlWhole).row
'do some more stuff
Next rCell
lstqst = refqst
Set lstqstadrs = newqstadrs
End If
End If
End If
End If
Next o
You can only have one Find/FindNext pair. The second overrides the first. You need an alternate method for FindRangeTwo. Given that FindRangeTwo is a single column (gewaskolom) and you are looking for the row, application.match should do nicely.
Something like this,
dim newrowtwo as variant '<~~ should be variant type for IsError to catch
...
newrowtwo = application.match(rCell.Value, FindRangeTwo, 0)
if not iserror(newrowtwo) then
...
end if
...
Note that application.match is returning the position within FindRangeTwo, not the row on the worksheet. The actual row on the worksheet would be (newrowtwo + newrow - 1).
I tried the accepted answer of Loop through cells and add to a range with a little bit of variation, but my Range Arr was never appended.
When I tried to debug through it, it was only the first range. The Union never worked. Why is this?
Source code:
Public Function VisibleRows(InRange As Range) As Range
Dim R As Range
Dim Arr As Range
Dim RNdx As Integer
Dim Count As Integer
For RNdx = 1 To InRange.Rows.Count
Set R = InRange(RNdx)
If R.EntireRow.Hidden = False And R.Value2 <> "" Then
If Arr Is Nothing Then
Set Arr = R
Else
Set Arr = Union(Arr, R)
End If
End If
Next RNdx
VisibleRows = Arr
End Function
I can see a couple of problems with the code:
You're looping row by row, but the expression InRange(RNdx) takes the RNdx'th cell within the range - it goes horizontally first and then vertically. You probably want InRange.Cells(RNDx, 1)
Should be Set VisibleRows = Arr
Your function is returning a Range Object. Range objects are assigned to a variable with the word Set. You are not using this word. Try this, running TestMe().
Option Explicit
Public Sub TestMe()
VisibleRows(Range("A1:A10")).Select
End Sub
Public Function VisibleRows(InRange As Range) As Range
Dim R As Range
Dim Arr As Range
Dim RNdx As Integer
Dim Count As Integer
For RNdx = 1 To InRange.Rows.Count
Set R = InRange(RNdx)
If R.EntireRow.Hidden = False And R.Value2 <> "" Then
If Arr Is Nothing Then
Set Arr = R
Else
Set Arr = Union(Arr, R)
End If
End If
Next RNdx
Set VisibleRows = Arr
End Function
This is the sample result from it:
I'm currently trying to figure out how to write a macro that will allow me to run a index/match with two criteria. I have a large database of information containing transaction information from multiple countries. I'd like to reference data in the "country" column and "date" column to match with a separate worksheet that contains foreign exchange rates. For countries and dates that match it would return the exchange rate for that date. I'd like the macro to run down to the last row of data in my sheet (it varies from time to time)
The formula syntax I originally created is:
=INDEX('FX_Index Lookup'!G:G,MATCH('Tool'!CJ2&'Tool'!DT2,'FX_Index Lookup'!C:C&'FX_Index Lookup'!H:H,0),FALSE)
When I drag this formula down, excel runs out of resources to continue running the calculation on the amount of data (rows) I need. I was hoping a Macro could solve this issue
The last function MatchQuery will return cells in column ReturnCol, where CriteriaColA = CriteriaA, CriteriaColB = CriteriaB... (similar syntax to SUMIFS)
Set rngRes = MatchQuery(ReturnCol, CriteriaColA, CriteriaA, CriteriaColB, CriteriaB ... etc)
Public Function IsRange(ByRef vnt As Variant) As Boolean
If IsObject(vnt) Then
If Not vnt Is Nothing Then
IsRange = TypeOf vnt Is Excel.Range
End If
End If
End Function
Public Function Union(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
If rng1 Is Nothing Then
Set Union = rng2
Exit Function
End If
If rng2 Is Nothing Then
Set Union = rng1
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set Union = Application.Union(rng1, rng2)
End Function
Public Function MatchAll(ByRef vntLookupValue As Variant, _
ByRef rngLookupArray As Range) As Range
Dim rngArea As Range
Dim rngTemp1 As Range
Dim rngTemp2 As Range
Dim vntMatch As Variant
Dim lngCount As Long
Dim lngLast As Long
If rngLookupArray Is Nothing Then
Exit Function
End If
For Each rngArea In rngLookupArray.Areas
If rngArea.Columns.Count > rngArea.Rows.Count Then
Set rngTemp1 = rngArea.Rows
Else
Set rngTemp1 = rngArea.Columns
End If
For Each rngTemp2 In rngTemp1
With rngTemp2
lngCount = .Cells.Count
lngLast = 0
Do
vntMatch = Application.Match(vntLookupValue, .Parent.Range(.Cells(lngLast + 1), .Cells(lngCount)), 0)
If IsError(vntMatch) Then
Exit Do
End If
lngLast = lngLast + vntMatch
Set MatchAll = Union(MatchAll, .Cells(lngLast))
Loop Until lngLast = lngCount
End With
Next rngTemp2
Next rngArea
End Function
Public Function MatchQuery(ByRef rngLookupArray As Range, _
ParamArray avntArgs() As Variant) As Range
Dim rngResult As Range
Dim i As Long
Dim rngTemp As Range
Dim rngMatches As Range
Set rngResult = rngLookupArray
For i = 0 To UBound(avntArgs) - 1 Step 2
If Not IsRange(avntArgs(i)) Then
Exit Function
End If
Set rngTemp = avntArgs(i)
Set rngMatches = MatchAll(avntArgs(i + 1), Intersect(rngResult.EntireRow, rngTemp))
If rngMatches Is Nothing Then
Exit Function
End If
Set rngResult = Application.Intersect(rngResult, rngMatches.EntireRow)
Next i
Set MatchQuery = rngResult
End Function
I recently used code from a post by #LondonRob, which allows the format of a cell to be carried over with the containing data when using VLOOKUP.
Original question - Vlookup to copy color of a cell - Excel VBA
This is great and works for the majority of values. Unfortunately some values can't have the format carried across and I receive the error:
Run-time error "13": Data mismatch
I have taken out all empty cells and by trial and error taken out any formula errors and corrected misspellings. There are still a few cells bring this message up when trying to run the macro.
I can't see any errors in the data, and the occurrence of this error in cells appears to be almost random. The data set is also huge, so even finding all the problematic cells is proving difficult (I have located a few).
I would have commented on the thread, but I don't have the reputation at this point.
The coding used is (though in my module I took out the first 6 lines) -
Option Explicit
' By StackOverflow user LondonRob
' See https://stackoverflow.com/questions/22151426/vlookup-to-copy-color-of-a-cell-excel-vba
Public Sub formatSelectionByLookup()
' Select the range you'd like to format then
' run this macro
copyLookupFormatting Selection
End Sub
Private Sub copyLookupFormatting(destRange As Range)
' Take each cell in destRange and copy the formatting
' from the destination cell (either itself or
' the vlookup target if the cell is a vlookup)
Dim destCell As Range
Dim srcCell As Range
For Each destCell In destRange
Set srcCell = getDestCell(destCell)
copyFormatting destCell, srcCell
Next destCell
End Sub
Private Sub copyFormatting(destCell As Range, srcCell As Range)
' Copy the formatting of srcCell into destCell
' This can be extended to include, e.g. borders
destCell.Font.Color = srcCell.Font.Color
destCell.Font.Bold = srcCell.Font.Bold
destCell.Font.Size = srcCell.Font.Size
destCell.Interior.Color = srcCell.Interior.Color
End Sub
Private Function getDestCell(fromCell As Range) As Range
' If fromCell is a vlookup, return the cell
' pointed at by the vlookup. Otherwise return the
' cell itself.
Dim srcColNum As Integer
Dim srcRowNum As Integer
Dim srcRange As Range
Dim srcCol As Range
srcColNum = extractLookupColNum(fromCell)
Set srcRange = extractDestRange(fromCell)
Set srcCol = getNthColumn(srcRange, srcColNum)
srcRowNum = Application.Match(fromCell.Value, srcCol, 0)
Set getDestCell = srcRange.Cells(srcRowNum, srcColNum)
End Function
Private Function extractDestRange(fromCell As Range) As Range
' Get the destination range of a vlookup in the formulat
' of fromCell. Returns fromCell itself if no vlookup is
' detected.
Dim fromFormula As String
Dim startPos As Integer
Dim endPos As Integer
Dim destAddr As String
fromFormula = fromCell.Formula
If Left(fromFormula, 9) = "=VLOOKUP(" Then
startPos = InStr(fromFormula, ",") + 1
endPos = InStr(startPos, fromFormula, ",")
destAddr = Trim(Mid(fromFormula, startPos, endPos - startPos))
Else
destAddr = fromCell.Address
End If
Set extractDestRange = fromCell.Parent.Range(destAddr)
End Function
Private Function extractLookupColNum(fromCell As Range) As Integer
' If fromCell contains a vlookup, return the number of the
' column requested by the vlookup. Otherwise return 1
Dim fromFormula As String
Dim startPos As Integer
Dim endPos As Integer
Dim colNumber As String
fromFormula = fromCell.Formula
If Left(fromFormula, 9) = "=VLOOKUP(" Then
startPos = InStr(InStr(fromFormula, ",") + 1, fromFormula, ",") + 1
endPos = InStr(startPos, fromFormula, ",")
If endPos < startPos Then
endPos = InStr(startPos, fromFormula, ")")
End If
colNumber = Trim(Mid(fromFormula, startPos, endPos - startPos))
Else
colNumber = 1
End If
extractLookupColNum = colNumber
End Function
Private Function getNthColumn(fromRange As Range, n As Integer) As Range
' Get the Nth column from fromRange
Dim startCell As Range
Dim endCell As Range
Set startCell = fromRange(1).Offset(0, n - 1)
Set endCell = startCell.End(xlDown)
Set getNthColumn = Range(startCell, endCell)
End Function
Thanks
There's a lot of code there, so it's difficult to say what the exact issue might be.
Try this version:
Sub tester()
Dim c As Range
If TypeName(Selection)<>"Range" Then Exit Sub
For Each c In Selection
CopySourceFormats c
Next c
End Sub
'If the passed cell has a VLOOKUP formula,
' extract the arguments and find the source of the return value.
'Copy formatting from that cell to the cell with the formula
Sub CopySourceFormats(c As Range)
Dim arr, v, rng As Range, col As Long, f As String
Dim m, fs As Font, fd As Font, rngSrc As Range
'skip any unwanted cells
f = c.Formula
If Not f Like "=VLOOKUP(*" Then Exit Sub
If IsError(c.Value) Then Exit Sub 'no "source" cell to find
'Extract just the arguments and create an array
' (assumes no arguments contain a comma:
' would need better parsing otherwise)
f = Replace(f, "=VLOOKUP(", "")
f = Left(f, Len(f) - 1)
arr = Split(f, ",")
v = c.Parent.Evaluate(arr(0)) 'get lookup value
Set rng = Evaluate(arr(1)) 'source table (could be on another sheet)
col = CLng(arr(2)) 'column number in lookup table
'Debug.Print v, rng.Address(), col
'Try to match the value in the first column of the lookup table
m = Application.Match(v, rng.Columns(1), 0)
'Got a match? Copy formatting for the "source" cell
If Not IsError(m) Then
Set rngSrc = rng.Cells(m, col)
Set fs = rngSrc.Font
Set fd = c.Font
'copy formatting: add/subtract properties to suit...
fd.Size = fs.Size
fd.Color = fs.Color
fd.Bold = fs.Bold
c.Interior.ColorIndex = rngSrc.Interior.ColorIndex
End If
End Sub