I have a code to highlight words in a cell based on the values in another cells. It works perfectly when I assign FindW = Range("X1") . However the code does not seem to work when I assign range e.g:("X1:X1000") to the string value FindW and I could not find a way to fix this.
Does anyone have any idea?
See the code below:
Dim Rng As Range
Dim FindW As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Übersicht")
Application.ScreenUpdating = False
Application.EnableEvents = False
With ws
FindW = Range("X1:X1000")
y = Len(FindW)
For Each Rng In Range("C:H")
With Rng
m = UBound(Split(Rng.Value, FindW))
If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(Rng.Value, FindW)(x)
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & FindW
Next
End If
End With
Next Rng
End With
End Sub
You can't put the values of a Range of multiple cells directly into a single String variable. However, you can create a String Array and store each cell value individually in the String Array.
The easiest solution is to just use a Variant variable, and put the range values directly in it, like this :
Dim mrange As Range
Dim mVariant As Variant
mVariant = myRange.Value
If you really need your variable to be a String, there are multiples ways to do so:
For example, you can loop through each cell of the Array using something like :
For each mCell in mRange.Cells
mString(i) = mCell.Value
i = i + 1
Next mCell
mRange being your Range, and mString being a String Array. This solution requires for you to know how many cells are in the Range, since the String array needs to be defined with a size.
If you don't know the size of your Range, you can add a step and use a Variant variable.
See here.
Related
I want to remove the left character from a column of strings without looping over each cell, but I'm getting an error in Excel. Here is my code, can I do this without a for loop?
Public Sub TestRngAdjust()
Dim TestRNG As Range
Set TestRNG = Range("A1:A5")
TestRNG.NumberFormat = "#"
TestRNG.Value = Right(TestRNG.Value, Len(TestRNG.Value) - 1)
End Sub
If you don't want to loop:
Dim s As String
s = "RIGHT(" & TestRNG.Address & ",LEN(" & TestRNG.Address & ") - 1)"
TestRNG.Value = TestRNG.Parent.Evaluate(s)
But really, it's very easy to read the data into a Variant array, use Right on each element, then write the array back to the range.
Loops are not bad. They are bad when looping ranges on worksheets.
Use variant arrays to loop.
Using Variant method:
load range into a variant array.
loop the array and make changes.
assign variant array data back to range.
Public Sub TestRngAdjust()
Dim TestRNG As Range
Set TestRNG = Range("A1:A5")
Dim rngarr As Variant
rngarr = TestRNG.Value
Dim i As Long
For i = 1 To UBound(rngarr, 1)
rngarr(i, 1) = Mid$(rngarr(i, 1), 2)
Next i
TestRNG.NumberFormat = "#"
TestRNG.Value = rngarr
End Sub
Sorry That I posted my whole code for better visual. I created getcol function to give it the string( column name ) and it returns the range of that column
Public Function getColRange(colName As String) As String
'create variables that will be used in this function
Dim first As String
Dim last As String
Dim col As String
Dim first_row As Integer
Dim first_str As String
Dim last_col As String
Dim last_row As Integer
Dim last_str As String
'loop to check if colname is equal in range between columns A and X, easy to change below
For Each i In Range("A1:X1")
If i = colName Then
'catches column, first and last rows
col = Split(i.Address(1, 0), "$")(0)
last_row = Range("A2").End(xlDown).Row
first_row = 2
'make first and last addresses as strings
first_str = "" & col & first_row
last_str = "" & first_col & last_row
'function ouput in the next line is a combination of above two strings
getColRange = "" & first_str & ":" & col & last_str
End If
Next
End Function
Option Explicit
Sub proper_text()
Dim name_rng As Range
Dim name_cell As Range
Dim name_selection As String
Dim city_rng As Range
Dim city_cell As Range
Dim city_selection As String
Dim col_name As String
Dim trim_name_row As Long
Dim trim_name_rng As Range
Dim trim_name_cell As Range
Dim col_city As String
Dim trim_city_row As Long
Dim trim_city_rng As Range
Dim trim_city_cell As Range
With Credentialing_Work_History
' First Part
name_selection = getColRange("Company_Name")
Set name_rng = Range(name_selection)
For Each name_cell In name_rng
name_cell.Value = WorksheetFunction.Proper(name_cell.Value)
Next
city_selection = getColRange("Company_City")
Set city_rng = Range(city_selection)
For Each city_cell In city_rng
city_cell.Value = WorksheetFunction.Proper(city_cell.Value)
Next
'Second Part
col_name = getColRange("Company_Name")
' To 'Find the last used cell in Col A
trim_name_row = Range(col_name).End(xlDown).Row
'Declare the range used by having the coordinates of rows and column till the last cell used.
Set trim_name_rng = Range(Cells(2, 9), Cells(trim_name_row, 9))
' Loop through the range and remove any trailing space
For Each trim_name_cell In trim_name_rng
trim_name_cell = RTrim(trim_name_cell)
'Go to the next Cell
Next trim_name_cell
col_city = getColRange("Company_Name")
trim_city_row = Range(col_city).End(xlDown).Row
Set trim_city_rng = Range(Cells(2, 10), Cells(trim_city_row, 10))
For Each trim_city_cell In trim_city_rng
trim_city_cell = RTrim(trim_city_cell)
Next trim_city_cell
End With
End Sub
Referring to the Same Worksheet
Always use Option Explicit. If you would have used it, you would have noticed that the variables city_selection and city_cell, and i are not declared.
When having a 'ton' of variables, keep them close to the 'action' to make the code more readable (see in Quick Fix). Use shorter variable names, always preferably (but not necessarily) descriptive.
When using the With statement, you have to use the period (dot, .) in front of Worksheets, Range, Cells, Columns, Rows...etc., e.g.:
With Credentialing_Work_History
Set name_rng = .Range(name_selection)
End With
In this example, you have made sure that the range is in the worksheet Credentialing_Work_History.
You don't have to loop through the cells of the range, you can use Proper and Trim on a range (if you will allow Trim instead of RTrim).
You have to qualify your ranges i.e. make sure they refer to the correct worksheet. See this also in the corrections of the function (added ws parameter).
Note that the function would be more useful if it would return a range instead of a range address so you could use e.g. Set name_rng = getColRange(Credentialing_Work_History, "Company_Name"). That could be one of your next tasks.
The Code
Option Explicit
Sub proper_text()
' Name
Dim name_selection As String
Dim name_rng As Range
name_selection = getColRange(Credentialing_Work_History, "Company_Name")
If name_selection <> "" Then
Set name_rng = Credentialing_Work_History.Range(name_selection)
name_rng.Value = Application.Trim(Application.Proper(name_rng.Value))
End If
' City
Dim city_rng As Range
Dim city_selection As String
city_selection = getColRange(Credentialing_Work_History, "Company_City")
If name_selection <> "" Then
Set city_rng = Credentialing_Work_History.Range(city_selection)
city_rng.Value = Application.Trim(Application.Proper(city_rng.Value))
End If
End Sub
Function getColRange(ws As Worksheet, colName As String) As String
'create variables that will be used in this function
Dim first As String
Dim last As String
Dim col As String
Dim first_col As String
Dim first_row As Long
Dim first_str As String
Dim last_col As String
Dim last_row As Long
Dim last_str As String
Dim rg As Range
'loop to check if colname is equal in range between columns A and X, easy to change below
For Each rg In ws.Range("A1:X1")
If rg = colName Then
'catches column, first and last rows
col = Split(rg.Address(1, 0), "$")(0)
last_row = ws.Range("A2").End(xlDown).Row
first_row = 2
'make first and last addresses as strings
first_str = "" & col & first_row
last_str = "" & first_col & last_row
'function ouput in the next line is a combination of above two strings
getColRange = "" & first_str & ":" & col & last_str
End If
Next rg
End Function
Sub proper_text_QuickFix()
Dim ws As Worksheet: Set ws = Credentialing_Work_History
' Name
Dim name_selection As String
Dim name_rng As Range
Dim name_cell As Range
name_selection = getColRange(ws, "Company_Name")
Set name_rng = ws.Range(name_selection)
Debug.Print name_rng.Address
For Each name_cell In name_rng
name_cell.Value = WorksheetFunction.Proper(name_cell.Value)
Next
' City
Dim city_name_selection As String
Dim city_rng As Range
Dim city_name_cell As Range
city_name_selection = getColRange(ws, "Company_City")
Set city_rng = ws.Range(city_name_selection)
Debug.Print city_rng.Address
For Each city_name_cell In city_rng
city_name_cell.Value = WorksheetFunction.Proper(city_name_cell.Value)
Next
' Trim Name
Dim col_name As String
Dim trim_name_row As Integer
Dim trim_name_rng As Range
Dim trim_name_cell As Range
col_name = getColRange(ws, "Company_Name")
trim_name_row = ws.Range(col_name).End(xlDown).Row
Set trim_name_rng = ws.Range(ws.Cells(2, 9), ws.Cells(trim_name_row, 9))
Debug.Print name_rng.Address
For Each trim_name_cell In trim_name_rng
trim_name_cell = RTrim(trim_name_cell)
Next trim_name_cell
' Trim City
Dim col_city As String
Dim trim_city_row As Integer
Dim trim_city_rng As Range
Dim trim_city_cell As Range
col_city = getColRange(ws, "Company_City")
trim_city_row = ws.Range(col_city).End(xlDown).Row
Set trim_city_rng = ws.Range(ws.Cells(2, 10), ws.Cells(trim_city_row, 10))
Debug.Print trim_city_rng.Address
For Each trim_city_cell In trim_city_rng
trim_city_cell = RTrim(trim_city_cell)
Next trim_city_cell
End Sub
I have a sub which adds a column from a table to an array (strArr), loops through the array to determine which rows to delete, and adds the row I want to delete to another array (deleteArr). I then loop in reverse order to delete the row. It seems to work fine for a small number of rows, but completely hangs on rows where I have a few thousand matches in deleteArr, even if I let it run forever. Does anyone have an idea what is going on here?
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
x = 0
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
'resize the array and add the row value of what we want to delete
ReDim Preserve deleteArr(0 To x)
deleteArr(x) = i + 1
x = x + 1
End If
Next i2
Next i
'delete the row in reverse order so no rows are skipped
Set ws = Sheets("Employee")
y = UBound(deleteArr)
For i = totalRows To 2 Step -1
If i = deleteArr(y) Then
ws.Rows(i).EntireRow.Delete
If y > 0 Then
y = y - 1
End If
End If
Next i
End If
End Sub
You could try to union a range of all rows you want to delete, then delete in one shot. Code is untested, hopefully this points you in the right direction.
Public Sub DeleteRows(ByVal surveyString As String)
Dim surveyArr() As String
Dim retireArr() As String
Dim strArr() As Variant
Dim deleteArr() As Variant
Dim totalRows As Long
Dim tRange As String
Dim x As Long
Dim y As Long
Dim ws As Worksheet
Dim UnionRange As Range
'Split up fields to delete received from listBox
If surveyString <> "" Then
surveyArr = Split(surveyString, "|")
End If
totalRows = Sheets("Employee").Rows(Rows.Count).End(xlUp).Row
tRange = "L2:L" & CStr(totalRows)
strArr = Sheets("Employee").Range(tRange).Value
Set ws = Sheets("Employee")
If surveyString <> "" Then
'determine which rows match and need to be deleted
'the value in deleteArr is the row to delete
For i = 1 To UBound(strArr)
For i2 = 0 To UBound(surveyArr)
If strArr(i, 1) = surveyArr(i2) Then
If UnionRange Is Nothing Then
Set UnionRange = ws.Rows(i)
Else
Set UnionRange = Union(UnionRange, ws.Rows(i))
End If
End if
Next
Next
If Not UnionRange Is Nothing Then UnionRange.EntireRow.Delete
End If
End Sub
I have a table of data in format "numberletter" i.e. 1X, 2.5X, -5X etc. What I am trying to do is to grab the data, remove last character from each cell(there is always only one letter at the end of the value), multiply the result by a constant value and paste it back to a different cells.
Right now, with code below, I am able to get values from first table copied to the second table with last letter removed but the result is string instead of number.
Dim vData
Dim n As Long
Dim r As Long
vData = Range("E6:J500").Value
For n = 1 To UBound(vData, 1)
For r = 1 To 6
If Len(vData(n, r)) <> 0 Then vData(n, r) = Left$(vData(n, r), Len(vData(n, r)) - 1)
Next r
Next n
Range("R6:W500").Value = vData
I've tried to add function below, but I am not able to make it work with my previous code due to mismatch error. Any help would be appreciated.
Function ConvertArray(arrStr() As String) As Double()
Dim strS As String
Dim intL As Integer
Dim intU As Integer
Dim intCounter As Integer
Dim intLen As Integer
Dim arrDbl() As Double
intL = LBound(arrStr)
intU = UBound(arrStr)
ReDim arrDbl(intL To intU)
intCounter = intL
Do While intCounter <= UBound(arrDbl)
arrDbl(intCounter) = CDbl(arrStr(intCounter))
intCounter = intCounter + 1
Loop
ConvertArray = arrDbl
End Function
There may be another better way, but I find .Evaluate an interesting option which in this case could work for you.:
Sub Test()
Dim cnst As Long: cnst = 10
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
.Range("R6:W500") = .Evaluate("IFERROR(IF(ROW(1:500),LEFT(E6:J500,IF(ROW(1:500),LEN(E6:J500)-1)),"""")*" & cnst & ","""")")
End With
End Sub
Or with a little bit more flexibility with variable ranges:
Sub Test()
Dim rng1 As Range, rng2 as range, cnst As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
Set rng1 = .Range("E6:J500")
Set rng2 = .Range("R6:W500")
cnst = 10
rng2.Value = .Evaluate("IFERROR(IF(ROW(1:500),LEFT(" & rng1.Address & ",IF(ROW(1:500),LEN(" & rng1.Address & ")-1)),"""")*" & cnst & ","""")")
End With
End Sub
The IFFERROR is in there because you seem to check your range for length above 0 too.
Here you can find why I used ROW(1:500) in .Evaluate:).
The Type Mismatch error is caused because Range.Value returns a variant array not a string array. It is also a 2D Array.
Val() can be used by itself to return the string value as long as the left part of the string contains the value.
Function ConvertArray(arrStr() As Variant, Multiplier As Double) As Double()
Dim results() As Double
ReDim results(1 To UBound(arrStr), 1 To UBound(arrStr, 2))
Dim r As Long, c As Long
For r = 1 To UBound(arrStr)
For c = 1 To UBound(arrStr, 2)
results(r, c) = Val(arrStr(r, c)) * Multiplier
Next
Next
ConvertArray = results
End Function
Sub Test()
Dim data() As Variant
data = Range("E6:J500").Value
Range("R6:W500").Value = ConvertArray(data, 10)
End Sub
Sub Prep()
Range("E6:J500").Formula = "=RandBetween(1,1000)&""X"""
Range("E6:J500").Value = Range("E6:J500").Value
End Sub
You need the VBA Val(String) function. This will take the numerics from your string until it finds a letter. It does a bit more than that as described here.
So you could replace your:
For r = 1 To 6
If Len(vData(n, r)) <> 0 Then vData(n, r) = Left$(vData(n, r), Len(vData(n, r)) - 1)
Next r
With:
For r = 1 To 6
vData(n, r) = Val(vData(n, r)
Next r
I want to compare the content of two ranges in a worksheet to two strings on another worksheet. In the case of both conditions are met, the cell next to it has to be summes up with all prior matches.
The code that works fine with comparing it to one criteria:
Sub Makro1()
Dim FB As String
FB = ActiveWorkbook.Sheets("Form").Range("B3").Value
Dim MyRangeA As Range
Dim A As Range
Dim MyTotal As Long
Dim LastRow As Long
MyTotal = 0
LastRow = ActiveWorkbook.Sheets("Downloads").Cells(Cells.Rows.Count, "F").End(xlUp).Row
Set MyRangeA = ActiveWorkbook.Sheets("Downloads").Range("F3:F" & LastRow)
For Each A In MyRangeA
If A.Value = FB Then
MyTotal = MyTotal + A.Offset(, 1).Value
End If
ActiveWorkbook.Sheets("Downloads").Range("K3") = MyTotal
Next
End Sub
However, I just cannot figure out how to insert another criteria to my range. This is my current try that doesn't work:
Sub Macro1()
Dim FB As String
Dim MTH As String
FB = ActiveWorkbook.Sheets("Form").Range("B3").Value
MTH = ActiveWorkbook.Sheets("Form").Range("B5").Value
Dim MyRangeA As Range
Dim A As Range
Dim MyRangeB As Range
Dim B As Range
Dim MyTotal As Long
Dim LastRow As Long
MyTotal = 0
LastRow = ActiveWorkbook.Sheets("Downloads").Cells(Cells.Rows.Count, "F").End(xlUp).Row
Set MyRangeA = ActiveWorkbook.Sheets("Downloads").Range("F3:F" & LastRow)
Set MyRangeB = ActiveWorkbook.Sheets("Downloads").Range("D3:D" & LastRow)
For Each A In MyRangeA
For Each B In MyRangeB
If B.Value = MTH Then
MyTotal = MyTotal + A.Offset(, 1).Value
End If
Next
ActiveWorkbook.Sheets("Downloads").Range("L3") = MyTotal
Next
End Sub
Can anyone help my out with this one?
As Charles Williams wrote you could use SUMIFS. You can use it within your VBA routine if you are happy with case insensitive matching:
MyTotal = WorksheetFunction.SumIfs(MyRangeA.Offset(, 1), MyRangeA, FB, MyRangeB, MTH)
Or, if that is problematic, you could loop testing each item. However, depending on the size of your data, it is usually measurably faster to read everything into a VBA array, and loop through that, rather than going back to the worksheet for each item. In addition, it is generally faster to iterate by index For I = 1 to n ... Next I than to go through a For Each Someobject ... Next Someobject type of iteration. So if you did not want to use the above, I would try a code snippet similar to:
Dim I As Long
Dim vData As Variant
vData = Union(MyRangeA, MyRangeA.Offset(, 1), MyRangeB)
For I = 1 To UBound(vData)
If vData(I, 1) = FB And vData(I, 3) = MTH Then
MyTotal = MyTotal + vData(I, 2)
End If
Next I
Depending on your requirements, you might also, for the latter, consider adding
Option Compare Text
to the top of your macro.