I have a Product Name like this. I run vba code for extracting date, am not getting the result, it shows error - excel

Code:
Sub My_Date()
Dim endRow As Long
endRow = Cells(rows.Count, "B").End(xlUp).row
ActiveCell.FormulaR1C1 = _
"=DATEVALUE(IF(LEFT(RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),4))-1),3)=TEXT(TODAY()-1,""Mmm""),RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHA" & _
"-1),IF(LEFT(RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),3)=TEXT(TODAY()-1,""Mmm""),RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5)" & _
""")))"
range("B2").Autofill Destination:=range("B2:B" & endRow)
End Sub

You could write your own function.
This will split your text by the _ delimiter and return the bit that can be turned into a date.
Sub Test()
Dim endRow As Long
With ThisWorkbook.Worksheets("Sheet1")
endRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(2, 1), .Cells(endRow, 1)).FormulaR1C1 = "=ExtractDate(RC2)"
End With
End Sub
Public Function ExtractDate(Target As Range, Optional Delim As String = "_") As Variant
Dim SplitText As Variant
SplitText = Split(Target, Delim)
Dim Itm As Variant
For Each Itm In SplitText
If IsDate(Itm) Then
ExtractDate = CDate(Itm)
Exit For
End If
Next Itm
'If no date found return an #N/A error.
If ExtractDate = 0 Then ExtractDate = CVErr(xlErrNA)
End Function
The cell reference in the Test procedure "=ExtractDate(RC2)" is in the R1C1 format - it means this row (where the formula appears), column 2.

The solution proposed by Darren Bartrup-Cook has a serious pitfall: IsDate and CDate functions work with the month names in a current locale. Which means that in general case they do not recognize May 03 and alike as a date
Let's make it work. Here are the assumptions about our data:
There's a pattern in Product Names with _ as a delimiter: the date always comes sixth in a row.
The year is always meant to be the current one.
The name of the month is always indicated in full.
Function ExtractDate(Text As String)
Const Delimiter = "_"
Const Position = 5 ' starting from zero
ExtractDate = Split(Text, Delimiter)(Position)
End Function
Sub Main_Macro()
Dim Source As Range
Dim DateArea As Range
Set Source = Range(Range("B2"), Range("B2").End(xlDown))
Set DateArea = Source.Offset(0, -1)
With DateArea
.NumberFormat = "[$-409]mmmm d"
.Formula2R1C1 = "=ExtractDate(RC[1])"
.Value2 = .Value2
.NumberFormat = "dd-mm-yyyy"
End With
End Sub
Here:
"[$-409]mmmm d" force to recognize months in English
.Value2 = .Value2 replace the formula with real data
.NumberFormat = "mm-dd-yyyy" set the date format in a current locale

Related

VBA Problem with CountIf and dates and times: count not working

I have the same dates and times in two columns. Now I want to loop through the dates and times of the second column and count how many items in the first column ("A1:A10") are greater than the respective date and time in the loop. But the count is always zero ("C1:C10").
CountIf with dates and times
Sub countif_datetime()
Dim sheet1 As Worksheet
Dim my_range As Range
Dim i As Integer
Set sheet1 = Worksheets("Sheet1")
Set my_range = sheet1.Range("A1:A10")
For i = 1 To 10
sheet1.Cells(i, 3).Value = WorksheetFunction.CountIf( _
my_range, ">" & sheet1.Cells(i, 2).Value _
)
Next i
End Sub
When I use the same function (countif) in the worksheet ("D1:D10") the count is there.
I also tried to convert the dates to double and it did not work either.
I can't reproduce your error at my end, i.e. your code works for me
but since the formula works at your end, you could consider a formula approach
Sub countif_datetime()
With Worksheets("Sheet1")
With .Range("A1:A10").Offset(, 2)
.FormulaR1C1 = "=COUNTIF(R1C1:R10C1,"">"" & RC[-1])"
.Value = .Value ' turn formulas into values
End With
End With
End sub
or, with a slightly more general approach:
With Worksheets("Sheet1")
With .Range("A1:A10").Offset(, 2)
Dim firstRow As Long, _
lastRow As Long
firstRow = .Rows(1).Row
lastRow = .Rows(.Rows.Count).Row
.FormulaR1C1 = "=COUNTIF(R" & firstRow & "C1:R" & lastRow & "C1,"">"" & RC[-1])"
.Value = .Value
End With
End With

Remove dot in string, issue with numbers < 1000

I have a column with data taken from CSV file, the data contain the dot I need to remove. When I want to replace „.“(dot) with „“ (nothing) with VBA I have a wrong result. All numbers smaller than 1000 replace the comma, I have for example 122,49 and the result is 12249 which is wrong.
I tried several VBA codes, non of them worked.
If you can help me it would be great. I tried all options with formats..
Thank you.
2.078,00 -> 2078,00 ok
122,49 -> 12249 ko
328,28 -> 32828 ko
11.192,34 -> 11192,34 ok
Sub TEST()
Dim i As String
Dim k As String
i = "."
k = ""
Columns("P:P").Replace what:=i, replacement:=k, lookat:=xlPart, MatchCase:=False
End Sub
Actually this is a bug in Excel! It only happens in VBA. If you do the same replace from the user interface it works. The same from a recorded macro fails. So obviously a bug.
I recommend to read all the values into an array, then replace and then write them back. This way the error does not occur and using arrays is even faster than using ranges.
Option Explicit
Sub TEST()
Dim i As String
Dim k As String
i = "."
k = ""
Dim LastRow As Long 'find last used row (to reduce processed cells)
LastRow = Cells(Rows.Count, "P").End(xlUp).Row
Dim ReplaceValues() As Variant 'read all values into array
ReplaceValues = Range("P1:P" & LastRow).Value
Dim iRow As Long 'replace
For iRow = LBound(ReplaceValues) To UBound(ReplaceValues)
ReplaceValues(iRow, 1) = Replace(ReplaceValues(iRow, 1), i, k)
Next iRow
'write all values from array back into cells
Range("P1:P" & LastRow).Value = ReplaceValues
End Sub
Or, use Application.Substitute:
Sub Test()
Dim lr As Long
Dim arr As Variant
lr = Cells(Rows.Count, "P").End(xlUp).Row
arr = Range("P1:P" & lr).Value
Range("P1:P" & lr).Value = Application.Substitute(arr, ".", "")
End Sub
I'm not sure if I exactly understand your requirements, but see if this is doing what you want.
Function RemovePeriods(ByVal number As String) As String
RemovePeriods= Replace(number, ".", ",")
RemovePeriods= Replace(Left$(RemovePeriods, Len(number) - 3), ",", "") & Right$(RemovePeriods, 3)
End Function
'run from here
Sub Example()
Debug.Print RemovePeriods("2.078,00")
Debug.Print RemovePeriods("122,49")
Debug.Print RemovePeriods("328,28")
Debug.Print RemovePeriods("11.192,34")
End Sub
Output
2078,00
122,49
328,28
11192,34
Give this a try:
Sub dotKiller()
For Each cell In Intersect(Range("P:P"), ActiveSheet.UsedRange)
v = cell.Text
If InStr(v, ".") > 0 Then
cell.Clear
cell.NumberFormat = "#"
cell.Value = Replace(v, ".", "")
End If
Next cell
End Sub
If the cell does not contain a dot it will not be changed.
Before:
and after:
Try this
Sub Test()
Columns("P:P").Replace What:=Application.DecimalSeparator, Replacement:="", LookAt:=xlPart, MatchCase:=False
End Sub
Or manually File >> Options >> Advanced >> Uncheck (Use system separators)

More efficient alternative to For Each

I am trying to get a faster and more efficient code than this one, as range will increase a lot over time, so I will need to substitute For Each.
The macro would look up the value "Monday" through each cell of a column and, if found, it would return the value "Substract" in the preceding cell in column A.
Sub ForEachTest()
Dim Rng As Range
Set Rng = Range("B3:B1000")
For Each cell In Rng
If cell.Value = "Monday" Then
cell.Offset(0, -1) = "Substract"
End If
Next cell
End Sub
Loop within VBA rather than on the worksheet:
Sub faster()
Dim arr()
arr = Range("A3:B1000")
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 2) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:B1000") = arr
End Sub
EDIT#1:
This version addresses BigBen's concern that column B should not be overwritten so as to preserve any formulas in that column. Only column A is overwritten here:
Sub faster2()
Dim arr(), brr()
arr = Range("A3:A1000")
brr = Range("B3:B1000")
For i = LBound(brr, 1) To UBound(brr, 1)
If brr(i, 1) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:A1000") = arr
End Sub
You can avoid the loop by filtering your data and working with the resulting visible set of data.
This will only modify the cells in Column A when Column B = Monday. All other cells remain as-is
Sub Shelter_In_Place()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
lr As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:B" & lr).AutoFilter Field:=2, Criteria1:="Monday"
ws.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).Value = "Subtract"
ws.AutoFilterMode = False
End Sub
Try using Evaluate
Sub Test()
With Range("A3:A" & Cells(Rows.Count, 2).End(xlUp).Row)
.Value = Evaluate("IF(" & .Offset(, 1).Address & "=""Monday"",""Substract"","""")")
End With
End Sub

Partial Text String VBA

I am trying to create a "If statement" where I check column B if it contains a partial string ("BMC-"). Then write "Bill of Material" in column E.
I already have tried using a formula, but I would like this to written as a macro.
=IF(ISNUMBER(SEARCH("BMC-",B14)), "Bill of Material", "")
Sub Descriptions()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row ' From row 1 to
the last row with data
On Error Resume Next
If Cells(r, "B") = "BMC-9" > 0 Then
Cells(r, "E").Value = "Bill of Materials"
End If
Next
End Sub
I am wanting the code to loop until the last row to find all the strings that contains the partial text "BMC-" in column B to write "Bill of Materials" in column E
Just use the formula you already have, no looping required. Also declare your variables. Utilize variables in place of hard-coding constant values so that the code is easier to adjust and maintain. Something like this should work for you:
Sub tgr()
'Declare variables
Dim ws As Worksheet
Dim lHeaderRow As Long
Dim sSearchCol As String
Dim sOutputCol As String
Dim sTextToFind As String
Dim sTextToWrite As String
'Set this to the actual worksheet where you want the formula
Set ws = ActiveWorkbook.ActiveSheet
'Define variables
lHeaderRow = 13 'Header Row. Actual data and results will start on the next row
sSearchCol = "B" 'Column to search for the text
sOutputCol = "E" 'Column to output results
sTextToFind = "BMC-" 'Text to search for
sTextToWrite = "Bill of Material" 'Text that will be output when search text is found
'Use previously defined variables to establish range
With ws.Range(sOutputCol & lHeaderRow + 1 & ":" & sOutputCol & ws.Cells(ws.Rows.Count, sSearchCol).End(xlUp).Row)
If .Row <= lHeaderRow Then Exit Sub 'No data
'Apply your formula to all rows in the range at once
.Formula = "=IF(ISNUMBER(SEARCH(""" & sTextToFind & """," & sSearchCol & .Row & ")), """ & sTextToWrite & """, """")"
'Convert cells to values
.Value = .Value
End With
End Sub
Tim has a solid Like case, though I tend to use InStr():
Sub Descriptions()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row
'On Error Resume Next 'get rid of that... find error and fix/build logic, don't ignore it
If Instr(Cells(r, "B").Value, "BMC-9") Then
Cells(r, "E").Value = "Bill of Materials"
End If
Next
End Sub
You can try this approach using split() function:
Sub NewCode()
For r = 14 To Cells(Rows.Count, "B").End(xlUp).Row
Dim myArray As Variant
myArray = Split(Cells(r, "B"), "BMC-")
If UBound(myArray) > 0 Then
Cells(r, "E").Value = "Bill of Material"
End If
Next r
End Sub

Adding additional rows under a row, depending on the amount of used cells in a range

basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA

Resources