I have an Excel sheet as shown below:
I want to change the color for characters in column E depending on the values of C and D.
The output should be like what's shown below:
Column C = 1
Column D = 3
So column E's color should change in positions 1 to 3.
You can use the Characters function to change attributes of certain characters within a cell's text. The second parameter to Characters() is the length, not the end, however, so you just need to do a little math to get from your example to where you need to be.
For example:
Dim r As Range, intStart As Long, intEnd As Long
For Each r In Range("E1:E3")
intStart = r.Offset(, -2)
intEnd = r.Offset(, -1)
r.Characters(intStart, intEnd - intStart + 1).Font.Color = RGB(255, 0, 0)
Next
Related
I have a macro that allows me to open multiple files based on their names and copy sheets based on a criteria (if there's a value in column "X" then copy the row but only some colums "F,G,P,Q,W,X,Y) to another unique workbook.
the problem is in column F i have a color and i want to retrieve the color index but the macro leaves it blank
[1] Get data from A1:Z{n}
n = ws.Range("A" & Rows.Count).End(xlUp).Row ' find last row number n
v = ws.Range("A10:Y" & n).Value2 ' get data cols A:Y and omit header row
[2] build array containing found rows
a = buildAr2(v, 24) ' search in column X = 24
' [3a] Row Filter based on criteria
v = Application.Transpose(Application.Index(v, _
a, _
Application.Evaluate("row(1:" & 26 & ")"))) ' all columns from A to Z
[3b] Column Filter F,G,P,Q,W,X,Y
v = Application.Transpose(Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(a) - LBound(a) + 1 & ")"), _
Array(6, 7, 16, 17, 23, 24, 25)))) ' only cols F,G,P,Q,W,X,Y
Function buildAr2(v, ByVal vColumn&, Optional criteria) As Variant
' Purpose: Helper function to check in Column X
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, j&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
If Len(Trim(v(i, vColumn))) > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr2 = ar
End Function
How to copy filtered array values together with color format (column F)
You got the solution to filter a data field Array v by row AND column using the Application.Index property and write these data to a target sheet - c.f. Multi criteria selection with VBA
Your issue was to find a way to write not only data, but also the source color formatting of column F to the target cells, as an array per se contains values and no color info.
Write the filtered information to a defined STARTROW (e.g. 10), then you can use the item numbers of array a adding a headline offset headerIncrement) to reconstruct the source row numbers by a simple loop in order to get/write the color formats, too:
Code addition
' [4a] Copy results array to target sheet, e.g. start row at A10
Const STARTROW& = 10
ws2.Cells(STARTROW, 1).Offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
' **************************************************************************
' [4b] Copy color formats using available item number information in array a
' **************************************************************************
Dim sourceColumn&: sourceColumn = 6 ' <<~~ source column F = 6
Dim targetColumn&: targetColumn = 1 ' <<~~ becomes first target column
Dim headerIncrement&: headerIncrement = STARTROW - 1
For i = 0 To UBound(a)
ws2.Cells(i + headerIncrement, targetColumn).Offset(1, 26).Interior.Color = _
ws.Cells(a(i) + headerIncrement, sourceColumn).Interior.Color
Next i
Side Note Don't forget to set Option Explicit to force declaration of variables and to declare the variable howMany (used in both procedures) in the declaration head of your code module.
I have no idea where the problem is, but you asked:
the problem is in column F i have a color and i want to retrieve the
color index but the macro leaves it blank
Here's how you retrieve the colorindex from Cell A1:
col = Range("A1").Interior.ColorIndex
I would suggest you try retrieving it and if you run into a problem: open a question with your example, as Pᴇʜ suggested.
In addition to the comments above by #Pᴇʜ, the fact that you are mainly dealing with v, a variant array of strings, is going to be a limiting factor. You are going to have to deal with a Range if you want the .Interior.ColorIndex property of the cell (Range).
Also, if you want to be precise about the color, use color instead of ColorIndex.
ColorIndex will return the closest indexed color.
I am trying to replace text markers with certain text that is ordered in a column.
In column Tried..., I am using the below RandCell function to get a random cell from a range of cells:
Function RandCell(Rg As range, columnRange As range, headerRange As range) As Variant
'Dim rplc
Dim textRange
'get random cell
RandCell = Rg.Cells(Int(Rnd * Rg.Cells.Count) + 1)
'find column to replace
' rplc = RandCell.Find(headerRange)
End Function
In the column Wanted, I am using the following formular to substitute the values: =IF(COUNTIF(E3;"*"&$C$2&"*");SUBSTITUTE(E3;$C$2;C3);SUBSTITUTE(E3;$D$2;D3))
However, if I have more than 10 rows this solution is extremely awkward. Hence, I was thinking of implementing a function in vba.
As indicated above I tried to implement the functionality into the RandCell function. However, I am extremely new to vba and kindly ask you for your input!
I appreciate your replies!
UPDATE
Below you can see an example.:
First, a random text is choosen. Then for example in E3 the text marker in the random text is replaced by the value in C or D.
With data like:
in cols A, B, and D, the following macro:
Sub mrquad()
Dim L As Long, M As Long, N As Long, Kount As Long
Dim v1F As String, v1L As String
Kount = 10
With Application.WorksheetFunction
L = .CountA(Range("A:A")) - 1
M = .CountA(Range("C:C")) - 1
N = .CountA(Range("D:D")) - 1
For kk = 1 To Kount
v1 = Cells(.RandBetween(3, L + 2), "A").Value
v1F = Left(v1, Len(v1) - 3)
v1L = Right(v1, 3)
If v1L = "[1]" Then
v2 = Cells(.RandBetween(3, M + 2), "C").Value
Else
v2 = Cells(.RandBetween(3, N + 2), "d").Value
End If
Cells(kk, "F").Value = v1F & v2
Next kk
End With
End Sub
will pick 10 samples at random from column A and, depending on the suffix, pick a random replacement suffix from either column C or column D and place the result in column F:
The number of sample is determined by the Kount variable. The spaces in cols C or D are single spaces rather than empties.
I've got a series of .csv files that I'm importing, which contain color information I need to apply to the imported data. The color column is colon-delimited, and the data is pipe-delimited:
:::::65535::|ADAM 14-22TGH|CHERRY|twu|Diesel Fuel (RIG)|Fuel||
::::14994616:::|MARCO 41-12G|CRYSTAL|HVA|Diesel Fuel (RIG)|Rig Fuel|gal us|
:::65535:65535:65535:65535:|MARCO 41-12G|CRYSTAL|||||
The excel sheet contains defined colors for various data states (missing data, wrong data, too high, too low, etc.), so I loop through the imported data building a cell union, which I eventually apply colorization to:
Dim ds As Worksheet
Dim i As Long, j As Long, k As Long
Dim iUsedCol As Long, iUsedRow As Long, clrRequired As Long, color as Long
Dim rngRequired As Range
Dim colorMap As Variant
Dim colors() As String
clrRequired = CLng(GetSetting("Failed Required Field Check"))
' Get the values of the color column
iusedRow = ds.UsedRange.Rows.Count
colorMap = Range(ds.Cells(1, 1), Cells(iUsedRow, 1)).Value
' Delete the color map column
ds.Columns(1).EntireColumn.Delete
' Skip the first two rows
For i = 3 To iusedRow
colors = Split(colorMap(i, 1), ":")
' Offset by one column since we're deleting column 1 after
For j = 2 To UBound(colors) + 1
If colors(j - 1) = "" Then
Else
color = CLng(colors(j - 1))
' Required
If color = clrRequired Then
If rngRequired Is Nothing Then
Set rngRequired = ds.Cells(i, j)
Else
Set rngRequired = Application.Union(rngRequired, ds.Cells(i, j))
End If
End If
End If
Next j
Next i
' Set the colors
If Not rngRequired Is Nothing Then
rngRequired.Interior.color = clrRequired
End If
For simplicity I removed the three other identical checks for the other colors, but this is the pattern. Depending on the data this can be 50 rows or 12000 rows, with varying columns based on what is being checked. I have a report that takes over 20 minutes to run, and when I remove this coloring code it finishes in about 10 seconds.
Additionally here is what I am disabling while running the code:
Calculations
CancelKey
PrintCommunication
ScreenUpdating
Events
StatusBar
Alerts
Try the following code:
Dim ds As Worksheet
Dim i As Long, j As Long, k As Long
Dim iUsedCol As Long, iUsedRow As Long, clrRequired As Long, color As Long
'...
'Set ds = .....
'...
iUsedRow = ds.UsedRange.Rows.Count
' Skip the first two rows
For i = 3 To iUsedRow
colors = Split(ds.Cells(i, 1).Value, ":")
' Offset by one column since we're deleting column 1 after
For j = 2 To UBound(colors) + 1
If colors(j - 1) <> "" Then
ds.Cells(i, j).Interior.color = CLng(colors(j - 1))
End If
Next j
Next i
' Delete the color map column
ds.Columns(1).EntireColumn.Delete
That will process all colours in one loop. (That may be a problem if you are only trying to set certain colours, as defined by your GetSetting calls. If so, you may need to include an If statement to avoid processing if the colour specified isn't one of the colours you want to deal with.)
Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.
What I want to do is create a macro to look at a column (AF) and based on that value, compare column (BI), (BJ), and/or (BK) together and if its false, highlight the compared cells in yellow. I know that's a little hard to follow but this example should help clarify:
My Sheet has the following columns:
Column AF Column BI Column BJ Column BK
PRODUCT Height Length Width
I need a macro to look at the product type and compare the dimensions for that product as follows:
- If product = A, then Length = Width, if not then highlight Length and Width Cells
- If product = B then Length > Width, if not then highlight Length and Width Cells
- If product = C then Width > Height < Length, if not highlight Length, Width, and Height cells
- If product - D then Width = Length < Height, if not highlight Width, Length, and/or Height
My Data starts on row 3 and ends at row 5002.
I have tried researching this and was only able to find solutions that compare two cells then write a third column. I could combine an IF formula and conditional formatting to achieve this but I don't want to have this run all the time as the sheet will be sorted and color coded. I plan to place this macro into a command button.
Suggest to combine Statements such as Select Case, If...Then...Else, together with Operators And, Or. See the following pages:
https://msdn.microsoft.com/en-us/library/office/gg251599.aspx
https://msdn.microsoft.com/en-us/library/office/gg278665.aspx
https://msdn.microsoft.com/EN-US/library/office/gg251356.aspx
After which you should be able to write something that resembles this:
(Code below is just a sample, it will not work)
Select Case Product
Case A
If Length <> Width Then
Rem Highlight Length And Width Cells
End If
Case B
If Length <= Width Then
Rem Insert here the code to highlight Length And Width Cells
End If
Case C
If Width <= Height And Height >= Length Then
Rem Insert here the code to highlight Length, Width, and Height cells
End If
Case D
If Width <> Length And Length >= Height Then
Rem Insert here the code to highlight Width, Length, and/or Height
End If
End Sub
In case you don’t know to highlight the Width, Length and Height Cells; I suggest to do it manually while recording a macro, this shall give a good starting point.
I suggest to work with objects, defining variables for the Data range, each row being validated, the position of the fields to validate, etc. see below code with comments
Sub Highlight_Cells_based_Comparison()
Dim rData As Range
Dim rRow As Range
Dim rCllsUnion As Range
Rem Set variables to hold Fields position within the DATA range
Dim bPosProd As Byte, bPosHght As Byte, bPosLeng As Byte, bPosWdth As Byte
Rem Set variables to hold Fields values
Rem (data type Variant as don't know type of values these fields are holding, change as appropriated)
Rem see https://msdn.microsoft.com/en-us/library/office/gg251528.aspx)
Dim sProd As String, vHght As Variant, vLeng As Variant, vWdth As Variant
Dim lRow As Long
Rem Set Range (assuming it goes from column C to BK - change as needed)
Rem Not starting from column A on porpuse
Set rData = ActiveSheet.Range("C3:BK5002")
Rem Get Fields position from Header row
Rem Suggest to use this method instead of hard coding columns
On Error Resume Next
With rData
bPosProd = WorksheetFunction.Match("PRODUCT", .Rows(1), 0)
bPosHght = WorksheetFunction.Match("Height", .Rows(1), 0)
bPosLeng = WorksheetFunction.Match("Length", .Rows(1), 0)
bPosWdth = WorksheetFunction.Match("Width", .Rows(1), 0)
End With
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
Rem Loop thru each row excluding header
For lRow = 2 To rData.Rows.Count
Set rRow = rData.Rows(lRow)
With rRow
Rem Get Row Field values
sProd = .Cells(bPosProd).Value2
vHght = .Cells(bPosHght).Value2
vLeng = .Cells(bPosLeng).Value2
vWdth = .Cells(bPosWdth).Value2
Select Case sProd
Case A 'Change value of A as required
Rem If product = A, then Length = Width, if not then highlight Length and Width Cells
Rem If Length <> Width Then Highlight Length And Width 'Cells
If vLeng <> vWdth Then
Set rCllsUnion = Union(.Cells(bPosLeng), .Cells(bPosWdth))
Rem Suggest to use a subroutine for this piece as it's a repetitive task
Rem see https://msdn.microsoft.com/en-us/library/office/gg251648.aspx
GoSub CllsUnion_Highlight
End If
Case B
Rem repeat as in Case A with required changes
Case C
'...
Case D
'...
End Select: End With: Next
Exit Sub
Rem Subroutine to highlight cells
CllsUnion_Highlight:
With rCllsUnion.Interior
.Color = 65535
.TintAndShade = 0
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.PatternTintAndShade = 0
End With
Return
End Sub