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.
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 calculate the count of Unique values based on a condition.
For example,
For a value in column B, I am trying to count the Unique values in Column C through VBA.
I know how to do it using Excel formula -
=SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))
that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name
This is my code :
Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))
This is the sample data with the requirement
Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.
I don't know where I am going wrong. Kindly share your thoughts.
You may try something like this...
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
Then you can use it like below...
=GetUniqueCount($A$2:$B$10,C2)
Where A2:B10 is the data range and C2 is the name criteria.
I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:
Sub Unique
dim arr(10) as variant, x as variant
dim arr2() as variant
for x = 1 to 10 ' or whatever
arr(x) = cells(x, 1) ' or whatever
next x
arr2 = UniqueValuesArray(arr)
' now write some code to count the unique values, you get the idea
End Sub
Function UniqueValuesArray(arr As Variant) As Variant()
Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long
arrpos = 0
ReDim uniqueArray(arrpos)
For x = 0 To UBound(arr)
If UBound(Filter(uniqueArray, arr(x))) = -1 Then
ReDim Preserve uniqueArray(arrpos)
uniqueArray(arrpos) = arr(x)
arrpos = arrpos + 1
End If
Next x
UniqueValuesArray = uniqueArray
End Function
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.
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
I am having a sheet which contains range of values like "5670&&2","1281&&-3&-5&&7",... etc. in Column A.
Kindly help me to extract the output in VBA in following way:
For E.g 5670&&2 I require A1 cell contains 5670,B1 cell contains &&,C1 cell contains 2.
For E.g 1281&&-3&-5&&7,I would require that A1 cell contains 1281,B1 cell contains &&-,C1 cell contains 3,D1 cell contains &-,E1 cell contains 5,F1 cell contains && and G1 cell contains 7.
Pls help in the same .
Thanks.,
Here i have tried to write code to separate numbers from non-numbers. Numbers and non-numbers are copied to different columns, like Excel Text-To-Columns. Code is a little crazy, if u need i will provide comments. As input the ActiveSheet.UsedRange.Columns(1).Cells is used.
Option Explicit
Sub SeparateNumbers()
Dim targetRange As Range
Dim cellRange As Range
Dim charIndex As Integer
Dim oneChar As String
Dim nextChar As String
Dim start As Integer
Dim copiedCharsCount As Integer
Dim cellValue As String
Dim columnIndex As Integer
Set targetRange = ActiveSheet.UsedRange.Columns(1).Cells
For Each cellRange In targetRange
columnIndex = cellRange.Column
start = 1
copiedCharsCount = 0
cellValue = cellRange.Value
If (VBA.Strings.Len(cellValue) <= 1) Then GoTo nextCell
For charIndex = 2 To Len(cellValue)
oneChar = VBA.Strings.Mid(cellValue, charIndex - 1, 1)
nextChar = VBA.Strings.Mid(cellValue, charIndex, 1)
If VBA.IsNumeric(oneChar) And VBA.IsNumeric(nextChar) Then GoTo nextCharLabel
If Not VBA.IsNumeric(oneChar) And Not VBA.IsNumeric(nextChar) Then GoTo nextCharLabel
cellRange.Offset(0, columnIndex).Value = VBA.Strings.Mid(cellValue, start, charIndex - start)
columnIndex = columnIndex + 1
copiedCharsCount = copiedCharsCount + (charIndex - start)
start = charIndex
nextCharLabel:
If charIndex = Len(cellValue) Then
cellRange.Offset(0, columnIndex).Value = VBA.Strings.Right(cellValue, charIndex - copiedCharsCount)
End If
Next charIndex
nextCell:
Next cellRange
End Sub
Here is one more code. As a side product, function TextSplitToNumbersAndOther can be used independently as a formula to achieve the same effect.
To prevent accidental firing of the macro in a wrong sheet or a wrong column and overwriting neighbouring columns with scrap, named range "Start_point" should be defined by a user. Below this range in the same column, all data will be processed till the first blank row.
Spreadsheet example: http://www.bumpclub.ee/~jyri_r/Excel/Extracting_symbols_into_columns.xls
Option Explicit
Sub ExtractSymbolsIntoColumns()
Dim rng As Range
Dim row_processed As Integer
Dim string_to_split As String
Dim columns_needed As Long
Dim counter As Long
row_processed = 1
counter = 0
Set rng = Range("Start_point")
While rng.Offset(row_processed, 0).Value <> ""
string_to_split = rng.Offset(row_processed, 0).Value
columns_needed = TextSplitToNumbersAndOther(string_to_split)
For counter = 1 To columns_needed
rng.Offset(row_processed, counter).Value = _
TextSplitToNumbersAndOther(string_to_split, counter)
Next
row_processed = row_processed + 1
Wend
End Sub
Function TextSplitToNumbersAndOther(InputText As String, _
Optional SplitPieceNumber As Long) As Variant
Dim piece_from_split(100) As Variant
Dim char_from_input As String
Dim word_count As Long
Dim counter As Long
Dim char_type(100) As Variant
InputText = Trim(InputText)
If Not IsNull(InputText) Then
word_count = 1
piece_from_split(word_count) = ""
For counter = 1 To Len(InputText)
char_from_input = CharFromTextPosition(InputText, counter)
char_type(counter) = CharTypeAsNumber(char_from_input)
If counter = 1 Then
piece_from_split(word_count) = char_from_input
Else
If (char_type(counter - 1) = char_type(counter)) Then
piece_from_split(word_count) = piece_from_split(word_count) & char_from_input
'Merge for the same type
Else
word_count = word_count + 1
piece_from_split(word_count) = char_from_input
End If
End If
Next
End If
If SplitPieceNumber = 0 Then
TextSplitToNumbersAndOther = word_count
Else
If SplitPieceNumber > word_count Then
TextSplitToNumbersAndOther = ""
Else
TextSplitToNumbersAndOther = piece_from_split(SplitPieceNumber)
End If
End If
End Function
Function CharTypeAsNumber(InputChar As String, Optional PositionInString As Long) As Long
If PositionInString = 0 Then PositionInString = 1
If Not IsNull(InputChar) Then
InputChar = Mid(InputChar, PositionInString, 1)
Select Case InputChar
Case 0 To 9
CharTypeAsNumber = 1
Case "a" To "z"
CharTypeAsNumber = 2
Case "A" To "Z"
CharTypeAsNumber = 3
Case Else
CharTypeAsNumber = 4
End Select
Else
CharTypeAsNumber = 0
End If
End Function
Function CharFromTextPosition(InputString As String, TextPosition As Long) As String
CharFromTextPosition = Mid(InputString, TextPosition, 1)
End Function
You can write a UDF (user defined function) to achieve the objective.
Your two example are in an order (ascending) to filter out into adjacent columns in Excel (A, B, C, D...)
So is it correct to assume logically, that you will never have scenarios where you will have to break the string into non-adjacent columns? e.g. 1234 goes to A, && goes to C, 3 goes to D... resulting in A, C, D.
Asumption 2: That your splitted-string is not going to need columns more than Excel can provide.
Steps you may try:
1. Check your string is not empty
2. Split it by the characters other than numerics
3. At the start and end of each non-numeric character you may proceed to the next adjacent column.
search help: Split a string into multiple columns in Excel - VBA