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)
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 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 a series of addresses from which I need to extract postal codes.The data is very sloppily formatted (not separated, some with spacings some without etc..) meaning the only way I can think to extract the postcodes is to create a column to which is added only the values which contain Text and a Number as these are the only cells to contain the postal code.
The data is too messy to isolate exactly where the postcode lies but I would like something to return a result like above.
How could I return only cell O2 & P2 from the range K2:R2?
*Address here is made up
Though I believe that #DarrenBartrup-Cook has a better answer. This quick dirty little UDF will do it bassed on the mix of numbers and text like asked.
Function pcode(rng As Range)
Dim rngt As Range
Dim chr As String
Dim i As Integer
For Each rngt In rng
If Not IsNumeric(rngt) Then
For i = 1 To Len(rngt)
If IsNumeric(Mid(rngt, i, 1)) Then
pcode = Trim(pcode & " " & rngt.Value)
Exit For
End If
Next i
End If
Next rngt
End Function
Put this in a module attached to the workbook, NOT the worksheet code or ThisWorkbook code.
You would call it from the sheet with this formula:
=pcode(I5:P5)
For a VBA result you could use the code below.
In cell T2 enter =GetPostCode(K2:R2),
or in VBA you can use Debug.Print GetPostCode(Sheet1.Range("K2:N2"))
I can't remember where I got the pattern from, but can probably be improved.
Public Function GetPostCode(AddressRange As Range) As Variant
Dim rCell As Range
Dim sAddressString As String
For Each rCell In AddressRange
sAddressString = sAddressString & " " & rCell.Value
Next rCell
sAddressString = Trim(sAddressString)
GetPostCode = ValidatePostCode(sAddressString)
End Function
Public Function ValidatePostCode(strData As String) As Variant
Dim RE As Object, REMatches As Object
Dim UKPostCode As String
'Pattern could probably be improved.
UKPostCode = "(?:(?:A[BL]|B[ABDHLNRST]?|C[ABFHMORTVW]|D[ADEGHLNTY]|E[CHNX]?|F[KY]|G[LUY]?|" _
& "H[ADGPRSUX]|I[GMPV]|JE|K[ATWY]|L[ADELNSU]?|M[EKL]?|N[EGNPRW]?|O[LX]|P[AEHLOR]|R[GHM]|S[AEGKLMNOPRSTWY]?|" _
& "T[ADFNQRSW]|UB|W[ACDFNRSV]?|YO|ZE)\d(?:\d|[A-Z])? \d[A-Z]{2})"
Set RE = CreateObject("VBScript.RegExp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = UKPostCode
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count = 0 Then
ValidatePostCode = CVErr(xlErrValue)
Else
ValidatePostCode = REMatches(0)
End If
End Function
Edit: I thought it wasn't working as it only return E17 3RU which is in Walthamstow, but HE17 3RU isn't a valid postcode (http://www.royalmail.com/find-a-postcode) so it found the valid one.
I have a workbook where I need to be creating new sheets in which I need to change the formula of cells from I8 to I39 to be the sum of H8 and I8 of the previous sheet. So in sheet3 I8 value must be =H8+sheet2!I8.
Dim aCell As String
Dim bCell As String
Dim i As Integer
For i = 8 To 39
aCell = Cells(i, 7).Address
bCell = Cells(i, 8).Address '<--need this but on the previus sheet
Cells(i, 9).Formula = "= & aCell & "+" & bCell" '<--i need the formula to be "=i,8+i,8(previus sheet)
Next i
This was as far as I could get, you can see what I was trying to do but I don't know the syntax.
Borrowing a bit from Scott Craner's comment:
Dim PrevSheet As Integer
PrevSheet = Application.ActiveSheet.Index - 1
ActiveSheet.Range("I8:I39").FormulaR1C1 = "=RC-1 + " & Sheets(PrevSheet).Name & "!RC"
This works as long as you have the correct sheet selected, and the indexes of the sheets are defaults, that is Sheet1 is indexed 1, Sheet2 is indexed 2.
If you add or delete sheets, this might not always be the case.
You may be able to rely on the current Worksheet.Index property to retrieve the name of the previous sheet. The Range.Address property can supply the rest.
Sub newFormulas()
Dim i As Long
With Worksheets("Sheet3")
For i = 8 To 39
.Cells(i, 9).Formula = _
Chr(61) & .Cells(i, 8).Address(0, 0) & Chr(43) & _
Worksheets(.Index - 1).Range(.Cells(i, 9).Address).Address(0, 0, external:=True)
Next i
End With
End Sub
I've used soe ASCII codes with the Chr function to avoid having to deal with a lot of quoted string parts.
I have a number of ranges to concatenate independently and put the values of the concatenated ranges into different cells.
I want to:
concatenate values in Range A1:A10 and put the result in F1
then concatenate the Range B1:B10 and put the result in F2
then concatenate the Range C1:C10 and put the result in F3 etc.
The following macro concatenates range A1:A10 and then puts the results into F1 (which is what I want). However it also stores the information from the first concatenation into memory so that when it does the next concatenation, in cell F2 I get the concatenated results of F1 and F2 joined.
Sub concatenate()
Dim x As String
Dim Y As String
For m = 2 To 5
Y = Worksheets("Variables").Cells(m, 5).Value
'Above essentially has the range information e.g. a1:a10 in sheet variables
For Each Cell In Range("" & Y & "") 'i.e. range A1:A10
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'this provides the concatenated cell value
Next
Line1:
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next m
End Sub
Here is my ConcatenateRange. It allows you to add a seperator if you please. It is optimized to handle large ranges since it works by dumping the data in a variant array and working with it within VBA.
You would use it like this:
=ConcatenateRange(A1:A10)
The code:
Function ConcatenateRange(ByVal cell_range As range, _
Optional ByVal seperator As String) As String
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
... I would do this very differently... Why not create a function along the lines of:
Function ConcatMe(Rng As Range) As String
Dim cl As Range
ConcatMe = ""
For Each cl In Rng
ConcatMe = ConcatMe & cl.Text
Next cl
End Function
And then just, for example, set F1 = ConcatMe(A1:A10) or, then write code to assign the function to the cells you want...
Or, as #KazJaw mentioned in his comment, just set x="" before re-looping.
Hope this helps
it is similar to the idea posted here already. However, I use a for each loop instead of an array setup with nested for loops.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = "")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
This, I suppose would be faster than the array set up, as a new array is not created each time this function runs.
Right before Next m insert simple statement: x="" – KazimierzJawor Apr 8 '13 at 20:43
took me several minutes to notice this answer was under comments :p
Thanks for everything guys, for my purpose I have modified your suggestions and amended my code as it didn't quite fit into a neat function as I needed it to be more dynamic. See my code below. It does exactly what I need.
Sub concatenate()
Dim x As String
Dim Y As String
For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement
For T = 1 To 10 'This provides a rows reference to concatenate - Inner for statement
For Each Cell In Cells(T, Q) 'provides rows and column reference
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'This provides the concatenated cell value and comma separator
Next ' this loops the range
Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached
Line1:
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate
ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to
'give 2,3,4
ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2
x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range
Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again
Terminate: 'error handler
End Sub
#Issun's solution doesn't accept output from a worksheet array formula as the argument for the 'cell_range' parameter. But a slight modification to #Issun's code fixes this. I also added a check that ignores each cell whose value is FALSE.
Function ConcatenateRange( _
ByVal cellArray As Variant, _
Optional ByVal seperator As String _
) As String
Dim cell As Range
Dim newString As String
Dim i As Long, j As Long
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
If (cellArray(i, j) <> False) Then
newString = newString & (seperator & cellArray(i, j))
End If
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
For example:
A B (<COL vROW)
------ ------ -----------------
one 1 3
two 1 4
three 2 5
four 2 6
Enter into cell C1 the formula below and press CTRL+ENTER to store the formula as an array formula:
{=ConcatenateRange(IF(B3:B6=1,A3:A6),CHAR(10))}
I was looking further to see if there is a better way of writing concatenate function and found this. It seems that we all have the same working principle for the function. So its ok.
But my function is different that it can take multiple parameters, in combination of ranges, texts and numbers.
I assume that a delimiter is mandatory, so if i don't need it i just put "" as the last parameter).
I also assume that blank cells are not to be skipped. That's the reason why i want the function to take multiple parameters, so i can easily omit those that that i don't want in the concatenation.
Example of use:
=JoinText(A1:D2,F1:I2,K1:L1,";")
You can also use together text and number among the parameters:
=JoinText(A1:D2,123,F1:I2,K1:L1,"PQR",";")
I'd love to hear any comments or suggestions where it can be improved.
Here is the code.
Public Function JoinText(ParamArray Parameters() As Variant) As String
Dim p As Integer, c As Integer, Delim As String
Delim = Parameters(UBound(Parameters))
For p = 0 To UBound(Parameters) - 1
If TypeName(Parameters(p)) = "Range" Then
For c = 1 To Parameters(p).Count
JoinText = JoinText & Delim & Parameters(p)(c)
Next c
Else
JoinText = JoinText & Delim & Parameters(p)
End If
Next p
JoinText = Replace(JoinText, Delim, "", , 1, vbBinaryCompare)
End Function
Function ConcatenateRange to concatenate all cells in range if they are not empty and empty "" string.
Function ConcatenateRange(cellRange As Range, Optional Delimiter As String) As String
Dim cel As Range, conStr As String
conStr = ""
If Delimiter <> "" Then
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel & Delimiter
Next
ConcatenateRange = Left(conStr, Len(conStr) - Len(Delimiter))
Else
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel
Next
ConcatenateRange = conStr
End If
End Function
Its very simple brother, Look out of the Excel. No need for all cumbersome formula or VBA.
Just copy all the cells that you need to concatenate and paste it in the notepad. Now just select the space between the lines/columns (it's a TAB space actually) and find and replace it.. Done.. All cells are concatenated. Now just copy and paste it in the column and just verify.. Thats it :) Enjoy.
I suggest you to use Notepad++ for this :) Koodos
Vimarsh
Ph. D. Plant Biotech.
/