I have the following Public sub:
Public Sub HowToSort()
Dim i As Long, j As Long, h As Long, curCell As Range, cellBelow(1 To 10) As Variant
Dim sortOrder(1 To 10), colIsString(1 To 10) As Variant
For i = 1 To hdrCount
'Find location of a cell
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1")) ' Eventually extend outwards?
cellBelow(i) = curCell.Offset(0, 1).Value
If IsNumeric(cellBelow(i)) = False Then
colIsString(i) = True
sortOrder(i) = Application.InputBox(prompt:="Alphabetical = 'True' or Reverse Alphabetical = 'False' sorting for " & headRow(i), Type:=4)
ElseIf IsNumeric(cellBelow(i)) = True Then
colIsString(i) = False
sortOrder(i) = Application.InputBox(prompt:="Ascending = True or Descending = False for " & headRow(i), Type:=4)
Else
MsgBox ("Program does not recognize value contained in column" & headRow(i))
End
End If
Next i
End Sub
Which uses a global variable named headRow, containing an array of strings of names of the header row at the top of the worksheet. I am trying to use the match function to find the address of the cell where the header is located:
Set curCell = Application.WorksheetFunction.Match(headRow(i), Range("a1:z1"))
cellBelow(i) = curCell.Offset(0, 1).Value
I then want to use this address, offset it downwards one cell to find what type of data is entered, this data will be entered in array colIsString. However, the .Match function is not working, citing a 'Type Mismatch' error. I do not know how this could be? From my previous research it appears that the .Match command takes in a range, then searches that range to match a cell value. I have tried several incarnations of the .Match command with no success. Your thoughts appreciated...
H3lue
Use Find() instead:
Set curCell = Range("a1:z1").Find(headRow(i), , xlValues, xlWhole)
If Not curCell Is Nothing Then
'found the header
cellBelow(i) = curCell.Offset(0, 1).Value
'etc etc
Else
MsgBox "Header '" & headRow(i) & "' not found!"
End If
sortOrder and colIsString will go out of scope as soon as your sub exits though...
Related
First of all, I am completely new to VBA besides recording simple macros, so bear over with me.
I am creating a VBA macro to import and sort results from a poll, based on names from the answers.
The import will take place from a Data sheet and will be imported into a Results sheet, for this I am using the XLOOKUP function.
The poll will run every other week and each time, the results sheet will expand with one column showing the newest results.
If I were to use the function directly in the spreadsheet this would work:
=XLOOKUP(A3&"*";Data!$D$2:$D$20;Data!$F$2:$F$20;"F";2)
where A3&"*" is my lookup_value.
I made it work with the offset function, but since my lookup_value has to be absolute I need another solution which I can not figure out.
Sub RES_Farver()
Dim Farve_Cell As Range
For Each Farve_Cell In Range("B3:B50")
Farve_Cell.Value = _
Application.WorksheetFunction.XLookup(Farve_Cell.Offset(0, -1) & "*", _
Sheets("Data").Range("D2:D50"), Sheets("Data").Range("F2:F50"), "F", 2)
Next Farve_Cell
End Sub
Not that Range("B3:B50") will later be based on user input, so it can be dynamic and change over time, like I described earlier.
What would I have to use instead of Offset?
Thanks!
as suggested by #Siddharth Rout
Sub lookup()
Dim vRange As String
vRange = InputBox("Please enter the range.", "Range:", "B3:B50")
If vRange = "" Then Exit Sub
Range(vRange).Formula = "=XLOOKUP(A3&""*"",Data!$D$2:$D$20;Data!$F$2:$F$20,""F"",2)"
End Sub
I went with this
result= _
Application.WorksheetFunction.XLookup(Cells(Farve_Cell.Row, "A") & "*", _
Sheets("Data").Range("D2:D50"), Sheets("Data").Range("F2:F50"), "F", 2)
Then it will use the row Farve_Cell is at in column A.
I also modified the range to only rows containing values and to the current week as column, where I have stated the weeks of the year in row 11
In total it looks like this (with danish messages)
Sub RES_Farver()
Dim currentWeek As Integer
currentWeek = DatePart("WW", Date, , vbFirstFullWeek)
Dim weekColumn As Integer
Set weekCell = Range("11:11").Find(currentWeek)
If weekCell Is Nothing Then
MsgBox "Ugenummer ikke fundet"
Exit Sub
Else
weekColumn = weekCell.Column
End If
Dim lastRow As Integer
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim rng As Range
Set rng = Range(Cells(13, weekColumn), Cells(lastRow, weekColumn))
For Each Farve_Cell In rng
Dim result As String
result = _
Application.WorksheetFunction.XLookup(Cells(Farve_Cell.Row, "A") & "*", _
Sheets("Data").Range("D2:D50"), Sheets("Data").Range("F2:F50"), "F", 2)
If result = "Grøn" Then
Farve_Cell.Value = "GN"
Else
If result = "Gul" Then
Farve_Cell.Value = "GL"
Else
If result = "Rød" Then
Farve_Cell.Value = "RD"
Else
Farve_Cell.Value = ""
End If
End If
End If
Next Farve_Cell
End Sub
I would like to find the cells (or Rows) in Column B, Sheet1, who have matching values placed into ListBox2. Then, I'd like to change the value of a cell 4 columns over (using an Offset command).
I believe using a For loop is the most efficient way of going thru the values placed into ListBox2. I tried using a Forloop to go thru all values placed into ListBox2.List. Upon calling a value, the code would look for this value in Column B. Once found, it would "remember" the Row in which this value was found. Then, the code would use a Range/Offset command to change the value of a cell 4 columns over in that Row.
Private Sub ButtonOK_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim SerialList As Range
Dim SerialRow As Long
Dim i As Long
Set wb = ActiveWorkbook
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim strFind As Variant
With ws
For i = 0 To Me.ListBox2.ListCount - 1
Set SerialList = ws.Range("B:B").Find(What:=Me.ListBox2.List(i))
SerialRow = SerialList.Row
If Not SerialList Is Nothing Then
ws.Range("B", SerialRow).Offset(0, 4).Value = Me.ListBox2.List(i) 'error occurs here!
MsgBox (ListBox2.List(i) & " found in row: " & SerialList.Row)
Else
MsgBox (ListBox2.List(i) & " not found")
End If
Next i
End With
End Sub
The MsgBoxes do say the correct ListBox2.List(i) value and the correct SerialList.Row, meaning that the program is correctly finding the row in which the list box value is located. However, I get an error saying that my range is not correctly defined at line "ws.Range("B", SerialRow)....."
How do I select the cell I'm searching for to correctly set it to =Me.ListBox2.List(i)?
Couple of fixes:
Dim lv
'....
For i = 0 To Me.ListBox2.ListCount - 1
lv = Me.ListBox2.List(i)
Set SerialList = ws.Range("B:B").Find(What:=lv, LookAt:=xlWhole) '<< be more explicit
'don't try to access SerialList.Row before checking you found a match...
If Not SerialList Is Nothing Then
ws.Cells(SerialList.Row, "F").Value = lv '<< Cells in place of Range
MsgBox (lv & " found in row: " & SerialList.Row)
Else
MsgBox (lv & " not found")
End If
Next i
I have been trying so hard. I cant figure this out. I am working with two sheets. One sheet searches for a criteria "RR", ir there is an RR, it assigns a variable a serial to be searched in another sheet. If the serial is found in the other sheet, I would like to determine the row where it is located and assign it to a variable. "DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value" The problem when I use thiscell.Row, its giving me so many problems. I need the row number to so I can reference the same row to get information from another cell on the same row. Please help.
Sub TempModifier()
Dim NYSID, PLookUpTabRange, IsRR, DidTransfer As String
Dim thiscell As Range
'Variable for Temp
Dim TempFirstRow As Integer
Dim TempLastRow As Long
'Variables for the previous
Dim PreviousTabLastRow As Long
Dim PreviousTabFirstRow As Integer
'Initialize the temp variables
TempLastRow = Sheets("Temp").Range("D" & Rows.Count).End(xlUp).Row
PreviousTabName = "February"
PreviousTabFirstRow = 7
With Sheets(PreviousTabName)
PreviousTabLastRow = .Cells(256, "H").End(xlUp).Row 'Get the last row in the data range
End With
'Create a data-range variable
PLookUpTabRange = "H" & PreviousTabFirstRow & ":" & "H" & PreviousTabLastRow
'Begin looping structure to copy data from the temp tab to the current tab
For TempFirstRow = 2 To TempLastRow
'Assign the value of the housing unit
IsRR = Sheets("Temp").Cells(TempFirstRow, 2).Value
'Check if the value is RR
If IsRR = "RR " Then
'If the value is RR, then get the NYSID
NYSID = Worksheets("Temp").Cells(TempFirstRow, 4).Value
If Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Then
'NYSID is Found on Current Month Sheet, do Nothing
Else
DidTransfer = ""
Set thiscell = Sheets(PreviousTabName).Columns("D").Find(What:=NYSID, LookIn:=xlValues, lookat:=xlWhole)
DidTransfer = Sheets(PreviousTabName).Range("B" & thiscell.Row).Value
Select Case DidTransfer
Case "Transferred"
DidTransfer = "Transferred"
Case Else
DidTransfer = DidTransfer
End Select
If IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) Or _
(Not IsError(Application.Match(NYSID, Worksheets(PreviousTabName).Range(PLookUpTabRange), 0)) And _
DidTransfer = "Transferred") Then
'Worksheets("Temp").Rows(TempFirstRow).Delete
MsgBox "Delete"
End If
End If
End If
'Go to the next row
Next TempFirstRow
End Sub
I have a list of hyperlinks in Column A. Some work, some don't. I'm looking to make a script that checks if they work, then removes the ones that don't. What I have is:
Sub UndoLink()
Dim rng As Range
Dim i As Long
Dim n As String
i = 2
While i <= 4730
Set rng = Range("A" & i)
n = Range("A" & i).Value
If Worksheet.Function.FileExist(rng) = False Then
rng.Hyperlinks.Delete
i = i + 1
Else: i = i + 1
End If
Wend
End Sub
Public Function FileExist(path As String) As Boolean
If Dir(path) <> vbNullString Then FileExist = True
End Function
I'm getting a function error when I refer to FileExist in the sub. To clarify, the hyperlinks are all within strings like "648242," underlined in blue. If the path doesn't exist, I want to remove the hyperlink and keep the string. Is this possible?
To remove hyperlink:
rng.Hyperlinks.Delete
I need to find all instances of particular identifier that may occur in one column and concatenate them into one string.
The identifier will start with "ECP" and be separated by a dash or space and have several characters after the separator. E.g. "ECP 05-00012A1, "ECP-123456."
I was using the formula below, but didn't think of multiple "ECP numbers."
=INDEX('Raw WAM Data'!$A$1:$A$10000,MATCH(VLOOKUP("*"&"ECP"&"*",'Raw WAM Data'!$A$1:$A$10000,1,FALSE),'Raw WAM Data'!$A$1:$A$10000,0))
I was then parsing the data in an adjacent cell using: =LEFT($C$62,FIND(" ", $C$62, FIND(" ", $C$62)+1))
This string was then loaded into a UserForm TextBox.
I would then need concatenate all the returned values into one string separated by commas so that it can load into the UserForm TextBox.
I would think that VBA would be ideal for this, but I am open to any suggestions.
If I've got correct understanding of what you trying to achive then you can use something like this:
Sub TEST()
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, x&
With Sheets("Sheet1") 'replace sheet1 by name of your sheet
x = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In .Range(.[A1], .Cells(x, "A"))
If UCase(cl.Value2) Like "ECP*" And Not dic.exists(cl.Value2) Then
dic.Add cl.Value2, Nothing
End If
Next cl
End With
Debug.Print Join(dic.keys, Chr(10))
End Sub
test
Updated
What's the best way to put the results in Column E relative to the cell in which it was found? Also, if I wanted to search multiple columns, how should I adapt the code?
you can use this way:
Sub TEST2()
Dim cl As Range, x&
With Sheets("Sheet1") 'replace sheet1 by name of your sheet
x = .[A:C].Find("*", , , , xlByRows, xlPrevious).Row 'get the last used row in range
For Each cl In .Range(.[A1], .Cells(x, "C"))
If UCase(cl.Value2) Like "*ECP*" Then
If .Cells(cl.Row, "E").Value2 = "" Then
.Cells(cl.Row, "E").Value2 = cl.Value2
Else
.Cells(cl.Row, "E").Value2 = .Cells(cl.Row, "E").Value2 & "; " & cl.Value2
End If
End If
Next cl
End With
End Sub
Output
If your values are in column A of a worksheet this routine will gather your ECP numbers and load them into an array. You can then load the array into your TextBox.
Sub GatherECPs()
Dim ECParr
'Loop down each row starting at row 2 (assuming you have headers)
For x = 2 To SourceSheet.Range("A2").End(xlDown).Row
'Check if the start of the string is ECP
If Left(SourceSheet.Cells(x, 1).Value, 3) = "ECP" Then
'Add a row to the array
If IsEmpty(ECParr) Then
ReDim ECParr(0)
Else
ReDim Preserve ECParr(UBound(ECParr) + 1)
End If
'Add the value to the array
ECParr(UBound(ECParr)) = Right(SourceSheet.Cells(x, 1).Value, Len(SourceSheet.Cells(x, 1).Value) - 4)
End If
Next
End Sub
Replace SourceSheet with the sheet where your values exist.
To do it in a fast way which also works for multiple "ECP" in one cell just use this function:
Public Function getStr(rng As Range, ident As String) As String
Dim i As Long, x As Variant, y As Variant
For Each x In Intersect(rng, rng.Parent.UsedRange).Value
y = Split(x, ident)
If UBound(y) > 0 Then
For i = 1 To UBound(y)
getStr = getStr & ", " & ident & Split(y(i), ",")(0)
Next
End If
Next
getStr = Mid(getStr, 3)
End Function
It will return a comma separated string. just use it like: getStr(Range("A:A"), "ECP")
If you still have any questions, just ask ;)