I'm writing a macro to filter downloaded data according to a certain date range. The problem is that the cells containing dates in the downloaded data use the format mm/dd/yyyy, which Excel recognizes as text. Consequently, any program I write assumes that it is filtering text instead of dates, which causes a number of problems.
Is there a way to make this format recognized as a date by Excel? I tried defining the date cells using a custom number format but it didn't work. Any help would be appreciated.
Please, try the next code. It will convert the column in discussion in Date:
Sub convertTextToDate()
Dim sh As Worksheet, lastR As Long, col As String, arr, arrSp, arrD, i As Long
Set sh = ActiveSheet
col = "A" 'column where the string to be converted in date exists
lastR = sh.cells(sh.rows.count, col).End(xlUp).row
arr = sh.Range(col & "2:" & col & lastR).value
ReDim arrD(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
arrSp = Split(arr(i, 1), "/")
arrD(i, 1) = DateSerial(CLng(arrSp(2)), CLng(arrSp(1)), CLng(arrSp(0)))
Next i
With sh.Range(col & "2:" & col & lastR)
.value = arrD
.NumberFormat = "dd/mm/yyyy"
End With
End Sub
If you need a different format you should change "dd/mm/yyyy" with whatever you want. "mm.dd.yy", for instance...
Related
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
when I run find and replace through vba it changes my dates to us format. So I have a column of dates, but they are all prefixed with text that I want to remove (like so Invoice Date:dd/mm/yyyy). When I use Ctrl + F and replace manually, it's all great. Removes the text, the date remains in it's original format dd/mm/yyyy. However, when using vba to do this it changes the dates to mm/dd/yyyy if the the day is less than 12 (ie months in a year). I've tried a number of different methods to convert it but they all seem to have the same problem. Here is my latest failure...
Sub DateConvert()
Sheets("Sheet1").Select
Dim strValue As String
Dim RowCount As Integer
Dim x As Integer
Dim DateValue As Date
RowCount = WorksheetFunction.CountA(Range("C1", Range("C1").End(xlDown)))
For x = 2 To RowCount
'changes cell value to a string
strValue = Cells(x, 3).Value
'removes unwanted text
Cells(x, 3).Replace _
What:="Invoice Date:", Replacement:=""
'changes to string to desired date format
DateValue = Cells(x, 3).NumberFormat = "dd/mm/yyyy"
Next x
End Sub
Please, someone spare me this misery before either the laptop or me go out the window.
Thanks in advance
Dates are extremely annoying to work with. Your best bet for making sure you're working with the correct date is to use the DateSerial function, and then format the output as desired:
Sub DateConvert()
Dim ws As Worksheet: Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim rData As Range: Set rData = ws.Range("C2", ws.Cells(ws.Rows.Count, "C").End(xlUp))
If rData.Row < 2 Then Exit Sub 'No data
'Load range data into an array
Dim aData() As Variant
If rData.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = rData.Value
Else
aData = rData.Value
End If
'Loop over array and perform conversion
Dim aDateValues As Variant
Dim i As Long
For i = 1 To UBound(aData, 1)
aDateValues = Split(Replace(aData(i, 1), "Invoice Date:", vbNullString), "/") 'Remove the extra text and pull the date values
aData(i, 1) = DateSerial(aDateValues(2), aDateValues(1), aDateValues(0)) 'Use DateSerial to guarantee correct date
Next i
'Output results to sheet with desired date format
With rData
.Value = aData
.NumberFormat = "dd/mm/yyyy"
End With
End Sub
I am trying to change a column of text-based dates in a table into valued dates, so I can later filter them in the next line of code. I wanted the code to go through each row, get the value from the Due Date column, and return the date in the correct format. I get a Run-time error 438 - Object doesn't support this property or method.
'changes the date to correct format
For Each Row In ActiveSheet.ListObjects("ISP_Table")
DueDate = Range("ISP_Table[Due Date]")
Range("ISP_Table[Due Date]") = DateValue(DueDate)
Next Row
'filters out dates more than 3 months in the future
ActiveSheet.ListObjects("ISP_Table").Range.AutoFilter Field:=3, Criteria1:="<" & DateAdd("m", 1, Date)
Loop over the cells in the .DataBodyRange of the ListColumn in question:
Dim cell As Range
For Each cell in ActiveSheet.ListObjects("ISP_Table").ListColumns("Due Date").DataBodyRange
cell.Value = DateValue(cell.Value)
Next
Since looping cell-by-cell is slow, even better, use an array:
Dim rng As Range
Set rng = ActiveSheet.ListObjects("ISP_Table").ListColumns("Due Date").DataBodyRange
Dim arr() As Variant
arr = rng.Value ' read values into array
Dim i As Long
For i = Lbound(arr, 1) to Ubound(arr, 1)
arr(i, 1) = DateValue(arr(i, 1))
Next
rng.Value = arr ' write array back to sheet
I am hoping someone knows how to vlookup multiple comma separated values in one cell and provide semicolon separated output in the adjacent cell.
I have noticed two other instances of this question on Stack Overflow but, unfortunately, both referred to using formulas (textjoin and vlookup) to solve this issue. Due to another VBA formula I am using, I need the final output to result solely in the text information, not in a formula. Is there any way to do this using VBA? Thanks in advance.
Figured out how to use the vlookup with the split using Ben's suggestion. Only issue is it puts a semicolon at the start of my email string, which is no issue for me but may be for another user.
Sub FINDEM()
Dim ws As Worksheet
Dim cel As Range
Dim LastRow As Long, I As Long
Dim WrdArray() As String
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
For Each cel In .Range("A2:A" & LastRow).Cells 'loop through each cell in Column A
strg = ""
Sal = ""
WrdArray() = Split(cel, ", ")
For I = LBound(WrdArray) To UBound(WrdArray)
Sal = Sal & "; " & Application.WorksheetFunction.VLookup(WrdArray(I), Sheet1.Range("d2:e9"), 2, False)
cel.Offset(0, 1) = Sal
Next I
Next
End With
End Sub
You can do so without iteration, plus you might want to take into consideration removing duplicates. For example:
Sub Test()
Dim lr As Long
Dim arr As Variant, arrA As Variant, arrB As Variant
With ThisWorkbook.Sheets("Sheet1")
'Get last used row and data into memory
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:B" & lr).Value
'Join and transpose column A:A and B:B into their own array
With Application
arrA = Split(.Trim(Join(.Transpose(.Index(arr, 0, 1)), ",")), ",")
arrB = Split(.Trim(Replace(Join(.Transpose(.Index(arr, 0, 2)), ";"), Chr(10), "")), ";")
End With
'Write array to sheet
.Range("D2").Resize(UBound(arrA) + 1).Value = Application.Transpose(arrA)
.Range("E2").Resize(UBound(arrB) + 1).Value = Application.Transpose(arrB)
'Remove duplicates from column D:E
.Range("D2:E" & UBound(arrA) + 1).RemoveDuplicates Array(1, 2), xlNo
End With
End Sub
I have an Excel file with around 100,000 records. I have 6+ columns, the first five of which are:
Required Format:
So far I have :
Sub Main()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
sameRows = True
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 4
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 4), Cells(i + 1, 4)).merge
End If
sameRows = True
Next i
End Sub
I am able to get below by running the macro by changing value in Range from 4 to 1/2/3/4 and running macro four times.
Please help me get the data in required format. I still need to merge the empty fields with the previous non empty field.
Pratik, listen carefully to Jeeped. Working with large data in Excel isn't ideal, and working with raw data in merged cells is staring into the abyss - it's a dark, dark place where Range referencing and things like Offset functions will show you a dimension of despair you never knew existed.
If you have this data in another format, say XML, that you've imported into Excel then use VBA to read the data, query it, etc. in its original format. If it exists in a database, then, again, use VBA to access that database and manipulate the recordsets as you wish. If this is your only source of data, then why not write it into an XML document or into VBA's own data storage options (like Collection or arrays).
If you have to use Excel then don't confuse raw data with data display. Yes, the merged cells might be easier to read for the human eye, but I'd just pose the question: is that your primary objective in conducting the merge?
If you must take that leap into the abyss - and you can see that at least two of us would advise against - then at least speed things up by reading from an array and merging rows at a time:
Sub OpenDoorsToHades()
Dim dataSheet As Worksheet
Dim v As Variant
Dim mergeCells As Range
Dim mergeAreas As Range
Dim i As Long
Dim blankStart As Long
Dim blankEnd As Long
Dim doMerge As Boolean
Dim c As Integer
Set dataSheet = ThisWorkbook.Worksheets("data") 'rename to your sheet
'Read values into array of variants
With dataSheet
v = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
'Check for blanks
For i = 1 To UBound(v, 1)
If IsEmpty(v(i, 1)) Then
If Not doMerge Then
blankStart = i - 1
doMerge = True
End If
Else
If doMerge Then
blankEnd = i - 1
For c = 1 To 4
With dataSheet
Set mergeCells = .Range( _
.Cells(blankStart, c), _
.Cells(blankEnd, c))
If mergeAreas Is Nothing Then
Set mergeAreas = mergeCells
Else
Set mergeAreas = .Range(mergeAreas.Address & _
"," & mergeCells.Address)
End If
End With
Next
mergeAreas.Merge
Set mergeAreas = Nothing
doMerge = False
End If
End If
Next
'Format the sheet
dataSheet.Cells.VerticalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
How about just populating the empty cells with the values above, so the values on the far right are associated with the same values that would've been in the merged cell. For example, if 19 is in cell A2, you can recreate the table starting in G2 with =IF(A2<>"",A2,G1), and this way all empty cells will be populated with the value above, pairing the values at the far right with the exact same values.
I tackled the same problem myself this week. Ambie's solution seemed overly complex, so I wrote something pretty simple to merge rows:
Sub MergeRows()
Sheets("Sheet1").Select
Dim lngStart As Long
Dim lngEnd As Long
Dim myRow As Long
'Disable popup alerts that appear when merging rows like this
Application.DisplayAlerts = False
lngStart = 2
lngEnd = 2
For myRow = 2 To Range("A" & Rows.Count).End(xlUp).Row 'last row
If Range("A" & (myRow + 1)).value = "" Then
'include row below in next merge
lngEnd = myRow + 1
Else
'merge if 2+ rows are included
If lngEnd - lngStart > 0 Then
Range("A" & lngStart & ":A" & lngEnd).Merge
Range("B" & lngStart & ":B" & lngEnd).Merge
Range("C" & lngStart & ":C" & lngEnd).Merge
Range("D" & lngStart & ":D" & lngEnd).Merge
End If
'reset included rows
lngStart = myRow + 1
lngEnd = myRow + 1
End If
Next myRow
Application.DisplayAlerts = True
End Sub