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
Related
I have the following sheet:
I want to delete the rows whereever the city column contains "USA". ex. the desired output is below:
My approach is to create another column at C2:C4 with the =isnumber(search("USA",B2)). Then
for i = lastrow to 2 step -1
If cells(i, "C") then
Else
rows(i).delete
end if
next
This method works, but I feel is very stupid and runs very slow on large datasets. Any thoughts on achieving this elegantly?
The following should do what you want - assumes the data is on Sheet1 in columns A and B.
Sub Del_USA()
Dim c As Range
With Sheet1.Range("B:B")
Set c = .Find("*USA*", LookIn:=xlValues)
If Not c Is Nothing Then
With Sheet1.Cells(1, 1).CurrentRegion
.AutoFilter 2, "*USA*", 7
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
.AutoFilter
End With
Else
MsgBox "USA Not Found"
End If
End With
End Sub
Solution via WorksheetFunction FILTER()
Profiting from the new dynamic array features of Microsoft 365 you could simply use a formula to filter a given range of e.g. A2:B5.
=FILTER($A$2:$B$5,ISERROR(FIND(UPPER("uSa"),UPPER($A$2:$B$5)))*(LEN($A$2:$B$5)))
This formula approach displays results at another spill range. -
As, however you want to overwrite the original source range, you'd have to code a VBA procedure like this using the same basic worksheet functionality via Evaluate() (see section B):
Example call
Note that Find() doesn't need wild cards and I adapted the following code to allow also a case insensitive search.
Sub ExampleCall()
DelCrit "uSa", Sheet1.Range("A2:B5")
End Sub
Procedure DelCrit
Sub DelCrit(ExcludeTerm As String, rng As Range, Optional ByVal colNum As Long = 2)
'Auth:
Const PATTERN$ = "=FILTER($,ISERROR(FIND(UPPER(""?""),UPPER(~)))*(LEN(~)))"
'~~~~~~~~~~~~~~~~
'A) adapt formula
'~~~~~~~~~~~~~~~~
Dim rngAddr As String: rngAddr = rng.Parent.Name & "!" & rng.Address
Dim colAddr As String: colAddr = rng.Parent.Name & "!" & rng.Columns(colNum).Address
Dim MyFormula As String
MyFormula = Replace(Replace(Replace(PATTERN, _
"$", rngAddr), _
"~", colAddr), _
"?", ExcludeTerm)
'~~~~~~~~~~~~~~~~~~~
'B) get result array
' (2-dim matrix or "flat" 1-dim array)
'~~~~~~~~~~~~~~~~~~~
Dim result: result = Evaluate(MyFormula) ' << Code evaluation
'~~~~~~~~~~~~~~~~
'C) write result
'~~~~~~~~~~~~~~~~
rng = vbNullString
On Error Resume Next
rng.Resize(UBound(result), UBound(result, 2)) = result
If Err.Number Then ' provide for 1-dim "flat" array
rng.Resize(1, UBound(result)) = result
End If
End Sub
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 built a function to determine the first row in which data exists. When I call the data i keep getting an error stating object required. How do I get around this error and is this the best way to accomplish my goal? TYIA!
Sub rename()
Dim strOldType As String
Dim correctrow As Long
Dim a As Range
Set a = startrow(correctrow)
Range("s" & a).Select
strOldType = Selection.Value
End Sub
Function startrow(firstroww)
Dim strRow As String
Dim firstrow As Range
Range("ab1").Select
strRow = Selection.Value
If strRow <> "" Then
firstroww = 1
Else
Range("ab1").Activate
Selection.End(xlDown).Select
firstroww = ActiveCell.Row()
End If
End Function
You can try a function like this. You will need to pass a range into the function as seen below in Sub Test().
The custom function can find the first used cell below from any starting point.
Option Explicit
Function FR(Start As Range) As Long
Select Case Start
Case <> ""
FR = Start.Row
Case Else
FR = Start.End(xlDown).Row
End Select
End Function
Sub Test()
MsgBox FR(Range("A1"))
End Sub
Don't try to use Select inside a function.
Use Set to assign a range object. Do not use Set to assign a number to a variable.
Make up your mind whether you want a row number or a range object. You bounce back and forth between the two with no regard for result.
Corrected code:
Sub rename()
Dim strOldType As String
Dim correctrow As Long
Dim a As LONG '<~~ correction
correctrow = 1 '<~~ correction
a = startrow(correctrow) '<~~ correction
strOldType = Range("s" & a).Value
End Sub
Function startrow(firstroww)
if Range("ab" & firstrow) <> "" then '<~~ correction
startrow = firstrow
else
startrow = Range("ab" & firstrow).end(xldown).row
end if
End Function
First Cell in Column Function
It is assumed that you're looking for a VBA function to use in Excel to calculate the first non-empty row of a column (specified by a range).
Features
The Volatile method marks a user-defined function as volatile. A
volatile function must be recalculated whenever calculation occurs in
any cells on the worksheet. A nonvolatile function is recalculated
only when the input variables change (VBA Help).
At least for the sake of correctness, you have to use IsEmpty
instead of "" for the reason e.g. if the cell in the resulting row
contains a formula that evaluates to "", it will be ignored.
The Find Method Version uses the Find method to calculate the First Row, which is safer than
the End Version e.g. if you input a value into the first cell of the
column i.e. the result is 1 and you hide the first row, the result of
the End Version will not be 1.
The formula can be inserted in the same column as SelectRange
Column. In some cases the End Version would not show the correct
result or create a circular reference. Therefore ThisCell is used
in the End version and 0 is returned if no value was found in SelectRange column.
Find Method Version
Function FirstRowFind(SelectRange As Range) As Long
Application.Volatile
Dim FirstCell As Range
With Columns(SelectRange.Column)
Set FirstCell = .Find("*", .Cells(.Cells.Count), -4123, 1, 2, 1)
End With
If Not FirstCell Is Nothing Then
FirstRowFind = FirstCell.Row
End If
End Function
Find Method
Instead of
Set FirstCell = .Find("*", .Cells(.Cells.Count), -4123, 1, 2, 1)
you can use
Set FirstCell = .Find("*", .Cells(.Cells.Count), _
xlFormulas, xlWhole, xlByColumns, xlNext)
or
Set FirstCell = .Find(What:="*", After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
The parameters for the arguments LookAt(unimportant in this case) and SearchDirection(Default is Next) can be omitted, but since I couldn't find any difference in efficiency, I didn't.
Usage in Excel
For Column AB:
=FirstRowFind(AB1)
=FirstRowFind(AB20)
=FirstRowFind(AB17:AH234)
End Version (Not recommended)
Function FirstRowEnd(SelectRange As Range) As Long
Application.Volatile
Dim FirstCell As Range
If Application.ThisCell.Column = SelectRange.Column Then Exit Function
If Not IsEmpty(SelectRange.Cells(1)) Then
FirstRowEnd = 1
Else
Set FirstCell = Cells(1, SelectRange.Column).End(xlDown)
FirstRowEnd = FirstCell.Row
If FirstRowEnd = Rows.Count And IsEmpty(FirstCell) Then
FirstRowEnd = 0
End If
End If
End Function
Usage in Excel
For Column AB:
=FirstRowEnd(AB1)
=FirstRowEnd(AB20)
=FirstRowEnd(AB17:AH234)
You can use this:
ActiveSheet.UsedRange.Row
ActiveSheet.UsedRange.Column
The UsedRange object is the largest rectangle covering all nonempty cells.
I've got a date column that contains dates in mixed format. For example:
A
21.03.1990
03/21/1990
So, basically there are two different formats in one column: dd.mm.yyyy and mm/dd/yyyy. I'm trying to write a VBA script to change format of all dates in the column to be yyyy-mm-dd. That's what I've got so far:
Sub changeFormat()
Dim rLastCell As Range
Dim cell As Range, i As Long
Dim LValue As String
i = 1
With ActiveWorkbook.Worksheets("Sheet1")
Set rLastCell = .Range("A65536").End(xlUp)
On Error Resume Next
For Each cell In .Range("A1:A" & rLastCell.Row)
LValue = Format(cell.Value, "yyyy-mm-dd")
.Range("B" & i).Value = LValue
i = i + 1
Next cell
On Error GoTo 0
End With
End Sub
I know that it's not elegant piece of code, but I'm beginner with VBA so please forgive me.
The problem with that code is that it just rewrite unchanged A column into column B, when I change argument in Format function from yyyy-mm-dd to dd/mm/yyyy it works, but only for dates in format mm/dd/yyyy, and leaves dd.mm.yyyy untouched. I would appreciate any advice.
UPDATED: NEW ANSWER
Here is a solution that will do the job! The sub routine includes a function that does the replacement (the function itself is really useful!). Run the sub and all occurances in column A will be fixed.
Sub FixDates()
Dim cell As range
Dim lastRow As Long
lastRow = range("A" & Rows.count).End(xlUp).Row
For Each cell In range("A1:A" & lastRow)
If InStr(cell.Value, ".") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{2})\.(\d{2})\.(\d{4})", "$3-$2-$1")
End If
If InStr(cell.Value, "/") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{2})/(\d{2})/(\d{4})", "$3-$1-$2")
End If
cell.NumberFormat = "yyyy-mm-d;#"
Next
End Sub
Place this function in the same module:
Function RegexReplace(ByVal text As String, _
ByVal replace_what As String, _
ByVal replace_with As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.pattern = replace_what
RE.Global = True
RegexReplace = RE.Replace(text, replace_with)
End Function
How it works: I have a nifty RegexReplace function that allows you to do replace using regular expressions. The sub mearly loops through your A column and does a regex replace for those 2 cases you mentioned. The reason I use an Instr() first is to determain if it needs the replacement, and which kind. You could technically skip this but doing replace on cells that don't need it is really costly. At the end I format the cell to your custom date format regardless of what's inside for safe measure.
In case you aren't familiar with Regex (for ref: http://www.regular-expressions.info/), the expression I am using is:
Each item in () are capture groups - aka, the stuff you want to mess with
\d stands for a number [0-9].
{2} means 2 of, and {4} mean 4 of. I have been explicit here for safety.
The \ before the . in the first replace is needed since "." has special meaning.
In VBA regex, you refer to capture groups by using $ + no. of group. This is how I flip the order of the 3 items.
You don't really need VBA for this. This one-liner worksheet formula will do the trick:
=IF(ISERROR(FIND(".",A1)),IF(ISERROR(FIND("/",A1)),"invalid format",
DATE(RIGHT(A1,4),LEFT(A1,2),MID(A1,4,2))),
DATE(RIGHT(A1,4),MID(A1,4,2),LEFT(A1,2)))
This assumes the day and month are always given as two-digit numbers (e.g. always 03 and never just 3) and the year has four digits (i.e. "restricted" to years 1000-9999). But if this is not the case for you, then the formula can easily be adjusted to suit your purpose.
See if this does what you want. You may have to tailor it a bit for your own application.
Hope this helps!
Sub convertDates()
Dim rRng As Range
Dim rCell As Range
Dim sDest As String
Dim sYear, sMonth, sDay, aDate
'Range where the dates are stored, excluding header
Set rRng = Sheet1.Range("A2:A11")
'Column name of destination
sDest = "B"
'You could also use the following, and just select the range.
'Set rRng = Application.selection
For Each rCell In rRng.Cells
sYear = 99999
If InStr(rCell.Value, ".") > 0 Then
aDate = Split(rCell.Value, ".")
If UBound(aDate) = 2 Then
sDay = aDate(0)
sMonth = aDate(1)
sYear = aDate(2)
End If
ElseIf InStr(rCell.Value, "/") > 0 Then
aDate = Split(rCell.Value, "/")
If UBound(aDate) = 2 Then
sDay = aDate(1)
sMonth = aDate(0)
sYear = aDate(2)
End If
End If
With rCell.Range(sDest & "1")
If sYear <> 99999 Then
On Error Resume Next
.Value = "'" & Format(CDate(sMonth & "/" & sDay & "/" & sYear), "YYYY-MM-DD")
'If it can't convert the date, just put the original value in the dest
'cell. You can tailor this to your own preference.
If Err.Number <> 0 Then .Value = rCell.Value
On Error GoTo 0
Else
.Value = rCell.Value
End If
End With
Next
End Sub
#Jean-François Corbett has a formula solution that works but that might be shortened by more than half by foregoing the error message (on the basis that #VALUE! is as informative) and another IF, both DATEs, applying IFERROR rather than ISERROR, and SUBSTITUTE in place of one LEFT, MID, RIGHT set:
=IFERROR(1*(MID(A1,4,3)&LEFT(A1,3)&RIGHT(A1,4)),1*SUBSTITUTE(A1,".","/"))
This applies the interpretation mentioned by #Issun in the comment to the OP and assumes the output will be to cells formatted yyyy-mm-dd.
May be written with a subroutine like so:
Sub Macro1()
Range("B1:B10").Formula = "=IFERROR(1*(MID(A1,4,3)&LEFT(A1,3)&RIGHT(A1,4)),1*SUBSTITUTE(A1,""."",""/""))"
End Sub
Here is a simple solution to this:
Sub ChangeFormat1()
Dim ws as Worksheet
Set ws = Thisworkbook.Sheets("Sheet1")
LR = ws.cells(rows.count,1).End(Xlup).Row
with ws
For I = 1 to LR
.cells(I,2).value = .cells(I,1).value
Next
End with
ws.range("B1:B" & LR).numberformat = "yyyy-mm-dd"
End Sub
Month(Date) & "-" & Day(Date) & "-" & Year(Date)
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...