From cells E1:E25, I want to concat the word "hi" at the end of each word that exists in that range within my vba code. Here is what I have so far:
Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25").Value = Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25").Value + "hi"
It is giving me a "mismatch" error. Is there something I'm doing wrong?
I know there is a function to do this, I just want to know the VBA way.
Add Suffix
Copy both procedures to a standard module.
Adjust the values in the first procedure.
Only run the first procedure, the second is being called (by the
first).
The Code
Option Explicit
Sub addHi()
Dim rng As Range
Set rng = Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25")
addSuffix rng, "Hi"
End Sub
Sub addSuffix(ByRef DataRange As Range, ByVal Suffix As String)
Dim Data As Variant, i As Long, j As Long
' Write values from range to array.
Data = DataRange.Value
' Loop through rows of array.
For i = 1 To UBound(Data)
' Loop through columns of array.
For j = 1 To UBound(Data, 2)
' Check if current value in array is not an error.
If Not IsError(Data(i, j)) Then
' Add suffix.
Data(i, j) = Data(i, j) & Suffix
' Write new current value to the Immediate window (CTRL+G).
'Debug.Print Data(i, j)
End If
Next j
Next i
' Write values from array to range.
DataRange.Value = Data
End Sub
#Tim Williams is correct. Loop over the cells in the range and update the values.
For Each Cell In Workbooks("Test.xlsx").Worksheets("Sheet1").Range("E1:E25")
Cell.Value = Cell.Value + "hi"
Next
Related
I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")
This code works almost perfectly. The problem is it includes blank cells in its "matched" results. What do I need to change to make this code ignore blank cells? Below I will include an example of what is going on.
Sub MarkMatches()
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
Thank you #Variatus for the code and help so far!
I tried to work with your original code, but honestly I became very confused. My example below will illustrate some practices that could help (and those who may review your code later, including yourself!). So here's a list of comments:
Always use Option Explicit. Your code may already have this, but I'm listing it here for completeness sake.
Create variable names that describe what data it holds. Your code does a little of this, but some of the variable names are difficult to fit into the logic flow. My idea in coding is always to try and write self-documenting code. That way, it's nearly always clear what the code is trying to accomplish. Then I'll use comment for code blocks where it might be a bit less clear. (Don't fall into the trap of prefixing variable names with a "type" or something; it's ultimately not worth it.)
A clear description of the problem always helps. This is true not only to get help on SO, but also for yourself. My final comment to your post above, asking about the problem description really simplified everything. This includes describing what you want your output to show.
As per the problem description, you need to identify each unique item and keep track of which row you find that item so you can create a report later. A Dictionary is a perfect tool for this. Read up about how to use a Dictionary, but you should be able to follow what this block of code is doing here (even without all the previous declarations):
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
It's easy to see how the logic of this code follows the description of the problem. After that, it's just a matter of running through each row in the data area and checking each value on that row to see if duplicates exist on any other row. The full example solution is below for you to study and adjust to fit your situation.
Option Explicit
Sub IdentifyMatches()
Dim ws As Worksheet
Set ws = Sheet1
Dim dataArea As Range
Set dataArea = ws.Range("A1:F6")
Dim items As Dictionary
Set items = New Dictionary
'--- build the data set of all unique items, and make a note
' of which row the item appears.
' KEY = cell value
' VALUE = CSV list of row numbers
Dim rowList As String
Dim cell As Range
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
'--- now work through the data, row by row and make the report
Dim report As String
Dim duplicateCount As Variant
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim dataRow As Range
For Each dataRow In dataArea.Rows
Erase duplicateCount
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim rowNumber As Variant
For Each cell In dataRow.Cells
If items.Exists(cell.Value) Then
rowList = items(cell.Value)
Dim rowNumbers As Variant
rowNumbers = Split(rowList, ",")
For Each rowNumber In rowNumbers
If rowNumber <> cell.Row Then
duplicateCount(rowNumber) = duplicateCount(rowNumber) + 1
End If
Next rowNumber
End If
Next cell
report = vbNullString
For rowNumber = 1 To UBound(duplicateCount)
If duplicateCount(rowNumber) > 0 Then
report = report & rowNumber & "(" & duplicateCount(rowNumber) & ")" & ", "
End If
Next rowNumber
'--- display the report in the next column at the end of the data area
If Len(report) > 0 Then
report = Left$(report, Len(report) - 2) 'removes the trailing comma and space
dataRow.Cells(1, dataRow.Columns.Count + 1).Value = report
End If
Next dataRow
End Sub
I wrote a program using VBA which shown below. there was an array(ary) which contain(C,F,B,PC,PB). I create the loop to go through each variable in the array.
what I want to do with my code is I have a datasheet that includes that array values as categories. I want to assign each array values to p range. then execute data from the p range. then want to assign p to next array value and do the same.
but the problem is range p is firstly set ary(1)="C" and give the correct result. but after it becomes equal to "F" didn't work properly. it contains the same range previously gave. can anyone help me with this problem?
For i = 1 To UBound(ary)
cat = ary(i)
Set p = Nothing
Set c = Nothing
For Each c In Range("E:E")
If c.Value = cat Then
If p Is Nothing Then
Set p = c.Offset
Else
Set p = Union(p, c)
End If
End If
Next c
'get values
p.Offset(, -1).Copy Destination:=ws.Range("N" & Rows.Count).End(xlUp).Offset(1)
next i
The key error in your code is the idea that you might collect a range of non-consecutive cells and paste their value into a contiguous range. Excel can't do that. My code below collects qualifying values into an array and pastes that array into the target range.
The code below can't be exactly what you want because you didn't provide some vital information. However, please try it anyway with the aim of adapting it to your project.
Private Sub Review()
Dim Ws As Worksheet
Dim Rng As Range
Dim Rl As Long ' last row in column E
Dim Ary() As String
Dim Arr As Variant
Dim n As Long
Dim Cell As Range
Dim i As Long
Set Ws = Worksheets("Sheet1")
Ary = Split("C,F,B,PC,PB", ",") ' this array would be 0-based
Rl = Cells(Rows.Count, "E").End(xlUp).Row ' Range("E:E") has 1.4 million cells
Set Rng = Range(Cells(2, "E"), Cells(Rl, "E"))
For i = 0 To UBound(Ary)
ReDim Arr(1 To Rl)
n = 0
For Each Cell In Rng
If Cell.Value = Ary(i) Then
n = n + 1
Arr(n) = Cell.Offset(0, 1).Value
End If
Next Cell
If n Then
ReDim Preserve Arr(n)
'get values
Ws.Cells(Ws.Rows.Count, "N").End(xlUp).Offset(1) _
.Resize(UBound(Arr)).Value = Arr ' Application.Transpose(Arr)
End If
Next i
End Sub
This code works entirely on the ActiveSheet and then pastes the result to another sheet, named as "Sheet1". That isn't good practice. The better way would be to declare variables for both sheets and let the code refer to the variables so as to ensure that it has full control of which sheet it's working on at all times.
Set p = Union(p, c) will never be executed because it will only occur if p is NOT nothing, and Set p = Nothing is executed each time the outer loop iterates.
I am trying to find a way to:
Loop through a column (B column)
Take the values, store them in an array
Loop through that array and do some text manipulation
However, I cannot think of a way to loop through a column and take those values, storing them in an array. I have looked through Stack Overflow and google but have not found a successful solution.
In advance, thank you for your help.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i as Integer
Dim j as Integer
Dim lrow As Integer
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
i = eNumStorage ' I know this isn't right
Next i
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
End Sub
This is the easiest way to get column to array:
Public Sub TestMe()
Dim myArray As Variant
Dim cnt As Long
myArray = Application.Transpose(Range("B1:B10"))
For cnt = LBound(myArray) To UBound(myArray)
myArray(cnt) = myArray(cnt) & "something"
Next cnt
For cnt = LBound(myArray) To UBound(myArray)
Debug.Print myArray(cnt)
Next cnt
End Sub
It takes the values from B1 to B10 in array and it gives possibility to add "something" to this array.
The Transpose() function takes the single column range and stores it as an array with one dimension. If the array was on a single row, then you would have needed a double transpose, to make it a single dimension array:
With Application
myArray = .Transpose(.Transpose(Range("A1:K1")))
End With
MSDN Transpose
CPearson Range To Array
Creating an Array from a Range in VBA
Just adding a variation on Vityata's which is the simplest way. This method will only add non-blank values to your array. When using your method you must declare the size of the array using Redim.
Sub collectNums()
Dim eNumStorage() As String ' initial storage array to take values
Dim i As Long
Dim j As Long
Dim lrow As Long
lrow = Cells(Rows.Count, "B").End(xlUp).Row ' The amount of stuff in the column
ReDim eNumStorage(1 To lrow - 1)
For i = lrow To 2 Step -1
If (Not IsEmpty(Cells(i, 2).Value)) Then ' checks to make sure the value isn't empty
j = j + 1
eNumStorage(j) = Cells(i, 2).Value
End If
Next i
ReDim Preserve eNumStorage(1 To j)
'Not sure what this bit is doing so have left as is
If (IsEmpty(eNumStorage)) Then
MsgBox ("You did not enter an employee number for which to query our database. Quitting")
Exit Sub
End If
For j = LBound(eNumStorage) To UBound(eNumStorage) ' loop through the previous array
eNumStorage(j) = Replace(eNumStorage(j), " ", "")
eNumStorage(j) = Replace(eNumStorage(j), ",", "")
Next j
End Sub
I have an Excel table in which sometimes an entire cell has the following content:
pos=51;70;112;111;132;153
Note the whole content in in a single cell, that is to say the value 51;70;112... are strings clumped together in a single cell and not in their own cells.
Can I write a macro that in all cells that contain the keyphrase "pos=", add 2 to each value, so that the end result is:
pos=53;72;114;113;134;155
Here is a code that will do it (tested on a sample on my Excel 2003):
Sub t()
Dim rCells As Range, c As Range
Dim arr As Variant, i As Integer
'Define the range to apply the code
Set rCells = Range("A1")
For Each c In rCells
'check if the cell desserves to be changed (could be adapted though to another check)
If Left(c.Value, 4) = "pos=" Then
'split all the values after the "pos=" into an array
arr = Split(Mid(c.Value, 5, Len(c.Value)), ";")
'add +2 to every value of the array (we convert the value to be sure, probably unneeded)
For i = 0 To UBound(arr)
arr(i) = CLng(arr(i)) + 2
Next i
'set back the value to the worksheet
c.Value = "pos=" & Join(arr, ";")
End If
Next c
End Sub
Note that I didn't add the error checking part if your values aren't well formated.
You know that you can easily split data without using macros, right? Just use the TextToColumns function on the Data tab
But if you really want a macro, you can do something like the following:
Sub AddNumber()
Dim numberToAdd As Integer
numberToAdd = 2
Set myRange = Range("A1:A5")
For Each myCell In myRange
If Left(myCell.Value, 4) = "pos=" Then
arEquality = Split(myCell, "=")
arElements = Split(arEquality(1), ";")
For i = 0 To UBound(arElements)
arElements(i) = arElements(i) + numberToAdd
Next
myCell.Offset(0, 1).Value = arEquality(0) + "=" + Join(arElements, ";")
End If
Next
End Sub