I am trying to create a VBA code that when runs, find a certain string in column x but then gets the value to the right of the string in column y. If anyone could help that would be great thanks
You will need to adapt this but I see two ways of doing. Without knowing the answer, you could just use formulas.
Formula
Use a VLOOKUP ... Cell D2 = =VLOOKUP(D1,$A$1:$B$20,2,FALSE)
VBA
You need to change the column you want to search and the amount of columns you want to offset by to get the value.
You also need to adapt it to your solution. I've merely given you the approach and a couple of samples.
Using MATCH ...
Public Sub FindStringAndOffset()
Dim strToSearchFor As String, lngRow As Long, objSheet As Worksheet
Dim varValue As Variant, strColToSearchIn As String, lngOffset As Long
strToSearchFor = "Lookup 8"
strColToSearchIn = "A"
lngOffset = 1
Set objSheet = Sheet1
With objSheet
On Error GoTo ExitGracefully:
lngRow = WorksheetFunction.Match(strToSearchFor, .Range(strColToSearchIn & ":" & strColToSearchIn), 0)
varValue = .Range(strColToSearchIn & lngRow).Offset(0, lngOffset).Value
Debug.Print varValue
End With
ExitGracefully:
End Sub
... or using a VLOOKUP ...
Public Sub FindStringAndOffsetv2()
Dim strToSearchFor As String, objSheet As Worksheet
Dim varValue As Variant, strColToSearchIn As String, lngOffset As Long
Dim strColumnWithOffset As String
strToSearchFor = "Lookup 8"
strColToSearchIn = "A"
lngOffset = 1
Set objSheet = Sheet1
With objSheet
On Error GoTo ExitGracefully:
strColumnWithOffset = Split(.Range(strColToSearchIn & "1").Offset(0, lngOffset).Address, "$")(1)
varValue = WorksheetFunction.VLookup(strToSearchFor, .Range(strColToSearchIn & ":" & strColumnWithOffset), lngOffset + 1)
Debug.Print varValue
End With
ExitGracefully:
End Sub
There are a heap of ways to skin that cat.
Related
How do I get the position of the last non-empty cell in a filtered column without dropping the applied Autofilter? I understand it's easy to get the number of the last visible row with
Dim ws as Worksheet, rng As Range
Set rng = Range(Letter & 1 & ":" & Letter & 1) ' where Letter is the letter code of the column
GetLastVisibleRow = ws.Range(Split(ws.Cells(, rng.Column).Address, "$")(1) & ws.Rows.count).End(xlUp).row
but I need the number of the last filled row instead. At the same time, I'd like to avoid setting
ws.AutoFilterMode = False
if it's possible.
Thanks in advance.
Probably not the most efficient or fastest method, but this appears to work:
Function GetLastCellOfColumn(ColLetter As String) As Range
Dim Col As Range
Dim Rw As Long
Set Col = Range(ColLetter & ":" & ColLetter)
Set GetLastCellOfColumn = Intersect(ActiveSheet.UsedRange, Col)
For Rw = GetLastCellOfColumn.Cells.Count To 1 Step -1
If Len(GetLastCellOfColumn.Cells(Rw).Value) > 0 Then
Set GetLastCellOfColumn = GetLastCellOfColumn.Cells(Rw)
Exit Function
End If
Next
End Function
A charming solution by #jkpieterse plus a useful comment by #BigBen is exactly what I was looking for. Just to finalize the thread, the function returning the row number is
Function GetLastFilledCellOfColumn(ws As Worksheet, ColLetter As String) As Long
Dim Col As Range, Urng As Range, Rw As Long
Set Col = ws.Range(ColLetter & ":" & ColLetter)
Set Urng = Intersect(ws.UsedRange, Col)
For Rw = Urng.Cells.count To 1 Step -1
If Not IsEmpty(Urng.Cells(Rw)) Then
GetLastFilledCellOfColumn = Rw
Exit Function
End If
Next
End Function
Problem solved.
So maybe this is an alternative way to look into:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("_FilterDatabase").Columns(col)
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I'm afraid I rushed this a little and might have made a mistake but will have to get going. Hopefully you understand whats going on =)
Edit:
The above would definately work, but as figured out through the chat, there is actually a ListObject involved, called Table1, which throws of the AutoFilter range. So here are two alternative ways of doing the same thing:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("Table1")
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
Or, when you don't know the name of the table:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .ListObjects(1).Range
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I am trying to convert a text file to Excel sheet. I have to remove some data elements and copy some data elements to several columns. To remove some data, I have to look for a certain String (RUN). After I have that address, I have to search for the next RUN. Inside those two String range, I have to search for another String (NET) and remove it. I have to do it throughout the datasheet since this is frequent.
Here is the code I am trying to use.
Dim name As String: name = "RUN"
Dim secondName As String: secondName = "NET"
Dim rgSearch As Range
' set the range to entire sheet
Set rgSearch = Range(Cells.Address)
Dim rgSearch1 As Range
Dim cell As Range
'search for first occurrence of RUN
Set cell = rgSearch.Find(name)
Dim tempCell As Range
' If not found then exit
If cell Is Nothing Then
Debug.Print "Not found"
Exit Sub
End If
' Store first cell address
Dim firstCellAddress As String, firstRow As Integer, secondRow As Integer
'store address of first result
firstCellAddress = cell.Address
secondRow = cell.Row
Do
'save range to another range for next iteration
Set tempCell = cell.Select
'row variables are for alternate solution I tried
firstRow = secondRow
Debug.Print "Found: " & cell.Address
' search for next instance
Set cell = rgSearch.FindNext(cell)
,set next instance
secondRow = cell.Row
Set rgSearch1 = Range(tempCell, cell).Select
Loop While firstCellAddress <> cell.Address
I have also tried using
Set rgSearch1 = Range("B" & firstRow + 1 & ":B" & secondRow - 1).Select
instead of putting cells inside the range but I get the same result. That is why those firstRow, secondRow variables are there.
With both ideas, I am getting Object Required error. Could someone please show me what I am doing wrong?
I have an excel sheet which contains two columns called ProductName and CountryCode.i wanted to concatenate all the CountryCode separated by / based on the corresponding values in the column 'ProductName' and My output would be obtained in a separate column called 'FinalResults'. Please note that I used remove duplicate function to get unique values in Column C from Column A.
I tried the below VBA code with the help of stackoverflow and got the results.
Sub ProductCountry()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
Seems it works fine except for the first product PRO1. You could see it didn't concatenate the codes orderly and skipped the country code US and took the country code SG two times instead.
Can anyone help what went wrong in this script and I also got range error sometime if I use this same code for large data.
I rewrote it ...
Public Function ConcatenateCodes(ByVal strProductName As String, ByVal rngCells As Range, Optional ByVal strDelimiter As String = "/") As String
Application.Volatile
Dim objCell As Range, lngRow As Long, lngCol As Long, strThisProductName As String
Dim strCountry As String, lngBlank As Long
For lngRow = 1 To rngCells.Rows.Count
strThisProductName = Trim(rngCells.Cells(lngRow, 1))
strCountry = Trim(rngCells.Cells(lngRow, 2))
If strThisProductName & strCountry = "" Then
lngBlank = lngBlank + 1
Else
lngBlank = 0
If strProductName = strThisProductName Then
ConcatenateCodes = ConcatenateCodes & strDelimiter & strCountry
End If
End If
If lngBlank = 10 Then Exit For
Next
If ConcatenateCodes <> "" Then ConcatenateCodes = Mid(ConcatenateCodes, 2)
End Function
... I'm comfortable with the above but that's just me. It means the data doesn't need to be sorted and it will work.
Add the formula to your cell and watch it go.
If you concern about speed you should use arrays to handle your data:
Option Explicit
Public Sub CollectList()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'read values into array
Dim InputValues() As Variant
InputValues = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1)).Value
Dim UniqueList As Object
Set UniqueList = CreateObject("Scripting.Dictionary")
'collect all products in a dictionary
Dim iRow As Long
For iRow = 1 To UBound(InputValues, 1)
If UniqueList.Exists(InputValues(iRow, 1)) Then
UniqueList(InputValues(iRow, 1)) = UniqueList(InputValues(iRow, 1)) & "/" & InputValues(iRow, 2)
Else
UniqueList.Add InputValues(iRow, 1), InputValues(iRow, 2)
End If
Next iRow
'output dictionary into cells
iRow = 2 'start output in row 2
Dim itm As Variant
For Each itm In UniqueList
ws.Cells(iRow, "C").Value = itm
ws.Cells(iRow, "D").Value = UniqueList(itm)
iRow = iRow + 1
Next itm
End Sub
As can be seen by the other responses, there are many ways to accomplish your task.
But read VBA HELP for the Range.Find method
I submit the following to help you understand where you went wrong:
This is your problem line:
Set FoundCell = SearchRange.Find(SearchCell)
You only specify the what argument for the Find. So other arguments default to some uncontrolled value. In general, the after argument will default to the beginning of the range, so the first matching term you will Find for PRO1 will be in A3. Also, the 2nd SG is being picked up because the lookat is defaulting to xlPart and PRO1 is contained within PRO10.
So one way of correcting that portion of your code, would be to be sure to specify all the relevant arguments of the Find. eg:
Set FoundCell = SearchRange.Find(what:=SearchCell, after:=SearchRange.End(xlDown), lookat:=xlWhole)
I am putting together a basic macro to format a column to include reference letters. For example, one column has 1,2,3 and there is a cell where the user can input some letters and click a button. ABC for example. This when working shall format 1,2,3 to now be ABC1, ABC2, ABC3 etc.
I have achieved this somewhat but it only works for the letter A. See below:
Sub Macro4()
Range("A3:A60").Select
Selection.NumberFormat = Range("k11").Text & "0" & "0" & "0"
End Sub
Here's my attempt. I'm quite certain there is a better way:
Option Explicit
Sub TestMacro()
Dim MyRange As Range
Dim MyReference As Range
Dim MyArray() As Variant
Dim Counter As Long
Dim wf As WorksheetFunction
Dim Cell As Range
Dim val As Integer
Application.ScreenUpdating = False
Set wf = Application.WorksheetFunction
Set MyRange = Range("A3:A60")
For Each Cell In MyRange
val = Application.Evaluate("=MIN(SEARCH({0,1,2,3,4,5,6,7,8,9}," & Cell.Address & "&" & """0,1,2,3,4,5,6,7,8,9""" & "))")
Cell = CInt(Mid(Cell, val, Len(Cell) - val + 1))
Next Cell
Set MyReference = Range("B3")
MyArray = Application.Transpose(MyRange)
For Counter = LBound(MyArray) To UBound(MyArray)
MyArray(Counter) = MyReference & CStr(MyArray(Counter))
Next Counter
MyRange = Application.Transpose(MyArray)
Application.ScreenUpdating = True
End Sub
I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub
Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub