I have this formula
=INDEX(C1:C8,LARGE(IF((A1:A8>=H2)*(A1:A8<=H3)*(B1:B8=H4),ROW(C1:C8),""),1))
it will get the last section from range and name
but it gets laggy when i created a summary of section where i use this code
can anyone suggest a formula where it wont get lag
There are many ways to achieve the result you want, but a lot depends on your version of Excel.
The LARGE and ROW might be causing the delay. You could replace LARGE with MAX.
=INDEX(C1:C8,MAX((A1:A8>=H2)*(A1:A8<=H3)*(B1:B8=H4)*ROW(C1:C8)))
If you have Excel 365, XMATCH might do better. It has an option to search bottom to top:
=INDEX(C1:C8,XMATCH(H4,IF((A1:A8>=H2)*(A1:A8<=H3),B1:B8),0,-1))
Filtering the lookup array with the IF will reduce the compare operations for XMATCH.
Try either of the following code (using excel vba as a "sub" or within the worksheet as a "function"):
Function Code:
Function Test02(name01 As String, MaxDate As Range, MinDate As Range, Rng01 As Range)
'Rng01 Column 1 = "Date"
'Rng01 Column 2 = "jonjon"
'Rng01 Column 3 = "mtce"
Dim Arr01 As Variant ' Array of data
Dim i01 As Long 'Counter
Dim Temp01 As String 'saves the current "mtce" until a larger date is found
Dim TempDate
TempDate = 0
Arr01 = Rng01
For i01 = 1 To UBound(Arr01, 1)
If Arr01(i01, 1) < MaxDate And Arr01(i01, 1) > MinDate And Arr01(i01, 2) = name01 And TempDate < Arr01(i01, 1) Then
Test02 = Arr01(i01, 3)
TempDate = Arr01(i01, 1)
End If
Next i01
End Sub
Instead of having a function, you could use a "Sub" instead and only run it when there is an update, and keep the outputs as static strings.) You might have to edit the following code to repeat over the whole data set, but this should be a good start. If you could give me a better snapshot of how the data is laid out, I might be able to write this code this for you (if this is what you want).
This would be the basis of the sub:
Sub Test01()
Dim Arr01 As Variant ' Array of data
Dim i01 As Long 'Counter
Dim Temp01 As String 'saves the current "mtce" until a larger date is found
Dim TempDate
'Rng01 Column 1 = "Date"
'Rng01 Column 2 = "jonjon"
'Rng01 Column 3 = "mtce"
MinDate = Range("H2")
MaxDate = Range("H3")
name01 = Range("H4")
Rng01 = Range("A1:C8")
TempDate = 0
Arr01 = Rng01
For i01 = 1 To UBound(Arr01, 1)
If Arr01(i01, 1) < MaxDate And Arr01(i01, 1) > MinDate And Arr01(i01, 2) = name01 And TempDate < Arr01(i01, 1) Then
Temp01 = Arr01(i01, 3)
TempDate = Arr01(i01, 1)
End If
Next i01
Range("H5") = Temp01
End Sub
Related
I am writing a code to retrieve a specific date in a (somewhat) large excel spreadsheet(2,000 entries).
I just realize that my code will not work and it will only get worse. Could you please advise me.
I give to my function:
array() that contain my data from an excel spreadsheet
FirstDate which is the date I am looking for, as dd mm yyyy
DateSave() to save all the position where this date appears (multiple transaction on the same day)
The code will not be able to work with a database of 5,000 row as it will have to stack it if the date is at the end of the table. What could I do to fix this issue?
Thank you very much
Function looping(array() As Variant, FirstDate As Date, DateSave() As Long)
Dim i As Long
Dim PositionInArray As Long
PositionInArray = 0
For i = LBound(array, 1) To UBound(array, 1)
If array(i, 1) = FirstDate Then
ReDim Preserve DateSave(PositionInArray)
DateSave(PositionInArray) = i
PositionInArray = PositionInArray + 1
End If
'If end of list and array not initialize ie. Not value in it
If i = UBound(array, 1) And (Not DateSave) = -1 Then
Call looping(array(), FirstDate + 1, DateSave())
ElseIf i = UBound(array, 1) Then
'Array has been initialized
Exit For
End If
Next i
End Function
Edit: Change data base to excel spreadsheet
I've renamed the function and parameters. The function returns the result rather than having a ByRef parameter. I've used a collection to store the row indexes.
Function GetDatePositions(ByRef database() As Variant, ByVal searchDate As Date) As Long()
Const colDates As Long = 1 'the index of the column holding dates
Dim i As Long
Dim collRowIndexes As New Collection
For i = LBound(database, 1) To UBound(database, 1)
If database(i, colDates) = searchDate Then
collRowIndexes.Add i
End If
Next i
If collRowIndexes.Count = 0 Then
GetDatePositions = GetDatePositions(database, searchDate + 1)
Exit Function
End If
Dim res() As Long
ReDim res(0 To collRowIndexes.Count - 1)
Dim v As Variant
i = 0
For Each v In collRowIndexes
res(i) = v
i = i + 1
Next v
GetDatePositions = res
End Function
EDIT
There is no need to search each consecutive date. We just need to keep track of the next date that is bigger than the search date.
Function GetDatePositions(ByRef database() As Variant, ByVal searchDate As Date) As Long()
Const colDates As Long = 1 'the index of the column holding dates
Dim i As Long
Dim collRowIndexes As New Collection
Dim dateFound As Boolean
Dim nextDate As Date
Dim tempDate As Date
dateFound = False
For i = LBound(database, 1) To UBound(database, 1)
tempDate = database(i, colDates)
If tempDate = searchDate Then
dateFound = True
collRowIndexes.Add i
Else
If Not dateFound Then
If searchDate < tempDate Then
If nextDate = 0 Then
nextDate = tempDate
ElseIf tempDate < nextDate Then
nextDate = tempDate
End If
End If
End If
End If
Next i
'
If collRowIndexes.Count = 0 Then
If nextDate = 0 Then
Err.Raise 5, "GetDatePositions", "No date found"
Else
GetDatePositions = GetDatePositions(database, nextDate)
Exit Function
End If
End If
Dim res() As Long
ReDim res(0 To collRowIndexes.Count - 1)
Dim v As Variant
i = 0
For Each v In collRowIndexes
res(i) = v
i = i + 1
Next v
GetDatePositions = res
End Function
Obviously, an assumption that all dates are rounded is made. But if dates also contain time (hours, minutes, seconds) then tempDate = database(i, colDates) needs to be replaced with tempDate = VBA.Int(database(i, colDates))
I am new to VBA in Excel. I have looked through through the forum, but have not found an answer for my specific date VBA I am looking for. I have three date ranges in excel cells per row of data elements representing testing dates. Each of the three ranges has a start date and an end date columns A-F.
For each row of test date ranges, I would one cell in column G to calculate the month and year "MMMYY" for any months covered in any of the three date ranges. If the date ranges over three months, the resulting cell would list all three months.
Any help would be greatly appreciated. Thank you in advance.
Marc
Calculated VBA column G
A B C D E F G
1 T1 Start T1 End T2 Start T2 End T3 Start T3 End Months
2 02Nov20 16Nov20 17Nov20 19Nov20 02Nov20 1Jan21 Nov20
Dec20
Jan21
3 28Oct19 15Nov19 28Oct19 01Nov19 28Oct19 1Nov19 Oct20
Nov20
4 20Jul20 21Aug20 Jul20
Aug20
5 11Sep20 29Sep20 20Sep20 22Sep20 20Sep20 Sep20
Here is a macro that outputs ALL of the included month/year.
In order to find the data table, I used the .CurrentRegion property of the cell that contains T1 Start. Because of this, if the output were adjacent to the table, the second run would include that column. Accordingly, I wrote the results one column over (and hid the intervening column. But you could make any number of changes in determining the source table size if that is undesireable.
I also was not certain, from your screenshot, if the Dates were "real Excel Dates" formatted to look like ddmmmyy (except for Column F in your text table) or if they are strings. So there is code to account for the different things I see. Code could be simplified if the data is in a known format.
The output is text strings and the column is formatted as text. If you want the output to be real dates formatted as mmmyy, then code will need to be added so Excel does not erroneously convert 2 digit years to day of the month.
Be sure to read the notes in the macro, as it will help you understand what's going on.
Option Explicit
Sub mthList()
Dim cM As Collection
Dim rg As Range, dStart As Date, dEnd As Date
Dim vSrc As Variant, vRes As Variant
Dim i As Long, J As Long, K As Long
Dim d1 As Double, d2 As Double 'start and end dates
Dim WS As Worksheet, rRes As Range
'Find the table and read it into VBA array
Set WS = ThisWorkbook.Worksheets("Sheet1")
With WS
Set rg = .Cells.Find(what:="T1 Start", after:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If rg Is Nothing Then
MsgBox "No Data Table"
Exit Sub
End If
vSrc = rg.CurrentRegion
ReDim vRes(1 To UBound(vSrc, 1), 1 To 1)
End With
'Collect all the included dates
'Convert date strings to real dates if they are strings
For i = 2 To UBound(vSrc, 1)
Set cM = New Collection
For J = 1 To UBound(vSrc, 2) Step 2 'can have N pairs of dates
If vSrc(i, J) <> "" Then
d1 = theDate(vSrc(i, J)) ' need to make sure this is a date and not a text string
If vSrc(i, J + 1) = "" Then
d2 = d1
Else
d2 = theDate(vSrc(i, J + 1))
End If
On Error Resume Next 'remove duplicates since Collection cannot have two entries with same key
For K = d1 To d2
cM.Add Format(K, "mmmyy"), Format(K, "mmmyy")
Next K
On Error GoTo 0
End If
Next J
'Output the data to results array
For K = 1 To cM.Count
vRes(i, 1) = vRes(i, 1) & vbLf & cM(K)
Next K
vRes(i, 1) = Mid(vRes(i, 1), 2)
Next i
'write the results
'formatting is optional, and Styles may not work with non-English versions
Set rRes = rg.Offset(0, rg.CurrentRegion.Columns.Count + 1)
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.EntireColumn.NumberFormat = "#"
.Value = vRes
.WrapText = True
.EntireRow.AutoFit
.EntireColumn.AutoFit
.Style = "output"
.Offset(0, -1).EntireColumn.Hidden = True
End With
With rg.CurrentRegion
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Style = "Input"
End With
End Sub
Private Function theDate(d) As Double
If Not IsDate(d) Then
theDate = CDate(Left(d, Len(d) - 5) & " " & Mid(d, Len(d) - 4, 3) & " " & Right(d, 2))
Else
theDate = d
End If
End Function
EDIT:
To use my algorithm as a function, just need to remove all that stuff with regard to finding the table and writing results back to the worksheet:
Option Explicit
Function mthList(rg As Range) As String
Dim cM As Collection
Dim dStart As Date, dEnd As Date
Dim vSrc As Variant
Dim I As Long, J As Long, K As Long
Dim d1 As Double, d2 As Double 'start and end dates
Dim S As String
'Collect all the included dates
'Convert date strings to real dates if they are strings
vSrc = rg
Set cM = New Collection
For J = 1 To UBound(vSrc, 2) Step 2 'can have N pairs of dates
If vSrc(1, J) <> "" Then
d1 = theDate(vSrc(1, J)) ' need to make sure this is a date and not a text string
If vSrc(1, J + 1) = "" Then
d2 = d1
Else
d2 = theDate(vSrc(1, J + 1))
End If
On Error Resume Next 'remove duplicates since Collection cannot have two entries with same key
For K = d1 To d2
cM.Add Format(K, "mmmyy"), Format(K, "mmmyy")
Next K
On Error GoTo 0
End If
Next J
'Output the data to a string
For K = 1 To cM.Count
S = S & vbLf & cM(K)
Next K
mthList = Mid(S, 2)
End Function
Private Function theDate(d) As Double
If Not IsDate(d) Then
theDate = CDate(Left(d, Len(d) - 5) & " " & Mid(d, Len(d) - 4, 3) & " " & Right(d, 2))
Else
theDate = d
End If
End Function
As said in the comments one could use a dictionary
Function listMthYear(rg As Range) As String
' Goto Tools/Reference and check Microsoft Scripting Runtime
Dim dict As Dictionary
Set dict = New Dictionary
Dim sngCell As Range
For Each sngCell In rg
If IsDate(sngCell.Value) Then
Dim mth As Long
Dim yr As Long
Dim dte As Date
dte = sngCell.Value
mth = VBA.Month(dte)
yr = VBA.year(dte)
dte = VBA.DateSerial(yr, mth, 1)
' This will create an unique entry in the dictionary if not already created
dict(dte) = dte
End If
Next sngCell
Dim output As Variant, i As Long
output = dict.Keys
For i = LBound(output) To UBound(output)
output(i) = Format(output(i), "MMMYY")
Next i
listMthYear = Join(output, vbLf)
End Function
You could use the function as an UDF or like that
Sub TestIt()
Dim rg As Range
Set rg = Range("A3:E3")
MsgBox listMthYear(rg)
End Sub
How can I turn this table
ID Date Type Date
26 Date of Hire 01/15/1996
27 Date of Hire 10/01/2003
27 Seniority Date 12/04/1989
38 Date of Hire 07/13/2000
39 Date of Hire 06/01/1987
40 Date of Hire 12/11/1995
41 Date of Hire 05/01/2005
41 Seniority Date 09/22/1986
into this table, using VBA
ID Date Hired Sen Date
26 01/15/1996
27 10/01/2003 12/04/1989
38 07/13/2000
39 06/01/1987
40 12/11/1995
41 05/01/2005 09/22/1986
I've been trying to figure this our for far to long and unable to find a similar question on here which works with my data.
Appreciate any input!
Here is some code i've been playing with but i'm unable to get it to work. I know m offsests are likely not where they should be and im unable to get past the error commented below.
Sub LongtoWide()
Dim Rng As Range
Dim Dn As Range
Dim n As Long
Dim Col As Date
Dim twn As String
Dim c As Long
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count, 1 To 3)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
twn = Dn & Dn.Offset(, 1)
Col = Asc(Dn.Offset(, 1))
If Not .Exists(twn) Then
n = n + 1
.Add twn, n
Ray(n, 1) = Dn: Ray(n, 1) = Dn.Offset(, 1)
Ray(n, Col) = Dn.Offset(, 1) '<----Subscript out of range error
Else
Ray(.Item(twn), Col) = Dn.Offset(, 2)
End If
Next
c = .Count
End With
With Range("F1")
.Resize(, 3) = Array("ID", "DOH", "SenDate")
.Offset(1).Resize(c, 3) = Ray
End With
End Sub
Here's a VBA approach if you are interested. This works by looping through the ID column to detect when there is a change, then add the item to an array to output in the correct format.
Public Sub TransformData()
Dim IDs As Range
Dim ID As Range
Dim ws As Worksheet
Dim Output As Variant
Dim i As Long
Dim PrevID As String
Set ws = ThisWorkbook.Sheets("Sheet1") ' adjust as needed
Set IDs = ws.Range("A2:A9") 'Specify range to scan
ReDim Output(1 To 3, 1 To 5000) 'Create an array large enough
'Loop through each ID
For Each ID In IDs
i = i + 1
'When the id is the same, this is the seniority row, assuming seniority appears after DateHired
If ID = PrevID Then
i = i - 1
Output(3, i) = ID.Offset(0, 2) 'Update 3rd element
Else
Output(1, i) = ID
Output(2, i) = ID.Offset(0, 2)
End If
PrevID = ID
Next
'Output data
ReDim Preserve Output(1 To 3, 1 To i)
ws.Range("E1:G1") = Array("ID", "Date Hired", "Sen Date")
ws.Range("E2:G" & UBound(Output, 2) + 1) = Application.Transpose(Output)
End Sub
I want to select a range (of values, the whole column) for the values: FirstDate, EndDate and Number. My VBA:
The Output of the below VBA is highlighted (Column D) :
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
FirstDate = Cells(1, 1).Value
EndDate = Cells(1, 2).Value
Number = Cells(1, 3).Value ' "Number" For the syntax DateAdd.
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Range("D1").Value = i - 1
End Sub
As I wrote before I want to run my Macro not only for the first 3 cells (currently the macro works fine for the value (1,1) (1,2) (1,3)), as you can see above for FirstDate, EndDate and Number
I want to use for all dates in Column1, Column2, Column3 for example:
I already tried this:
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Range("D1").Value = i - 1
Next
End With
End Sub
But is still transforming the 1 row.
If I'm understanding what you need correctly it's because you're calling out Range("D1").Value so it will always update that cell. You can make it more dynamic by using the lRow variable you already set up to place it into the correct row.
Replacing this Range("D1").Value = i - 1 with this Cells(lRow, 4).Value = i - 1
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Cells(lRow, 4).Value = i - 1
'Range("D1").Value = i - 1
Next
End With
End Sub
I'm trying to create a search that will display the information on the list box.
I'm trying to search by name and date range, or by name, or by date only.
I have code, the date is correct but it displays all the names.
Private Sub cmdFind_Click()
Dim DateRange As Range, rCl As Range, rng As Range, Dn As Range
Dim Date1 As Date, Date2 As Date
Dim iX As Integer
Dim strName As String
Set DateRange = Sheet2.Range("A1").CurrentRegion.Columns(4)
Set rng = Sheet2.Range("A1").CurrentRegion.Columns(4)
Me.ListBox1.Clear
strName = Me.txtName.Text
Date1 = CDate(Me.txtDate.Value)
Date2 = CDate(Me.EndDate.Value)
For Each rCl In DateRange.Cells
For Each Dn In rng.Cells
If rCl.Value >= Date1 And rCl.Value <= Date2 And strName Then
ElseIf Dn.Value = strName Then
With Me.ListBox1
.AddItem Sheet2.Cells(rCl.Row, 1)
.List(.ListCount - 1, 1) = Sheet2.Cells(rCl.Row, 2)
.List(.ListCount - 1, 2) = Sheet2.Cells(rCl.Row, 3)
.List(.ListCount - 1, 3) = Sheet2.Cells(rCl.Row, 4)
.List(.ListCount - 1, 4) = Sheet2.Cells(rCl.Row, 5)
.List(.ListCount - 1, 5) = Format(Sheet2.Cells(rCl.Row, 6), "hh:mm:ss")
End With
End If
Next Dn
Next rCl
End Sub
Assuming that you are checking the date range only in the same line: Delete the second loop For Each Dn in rng.Cells as well as Next Dn) and replace the following condition with:
If (rCl.Value >= Date1 And rCl.Value <= Date2) And rCl.Offset(0, -3).Value = strName Then
BTW, it's the better method to use arrays than range loops.