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.
Related
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
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
Since I asked a wrong question in the last post, but still improved a lot (I already created a Planning table in Excel, if someone want it I will be happy to share), here is what im trying do to: Cell B2: Start Date and Cell B3: End Date
Example:
B2 --> 11/03/2019
B3 --> 22/04/2019
Here is my code so far with the help of this community
Option Explicit
Sub Sample()
Dim sDate As Date, eDate As Date
Dim NoOfWeeks As Long
Dim arr As Variant
Dim i As Long
Dim myCellToStart As Range
Set myCellToStart = Worksheets(1).Range("D4")
Dim myVar As Variant
Dim myCell As Range
Set myCell = myCellToStart
With Worksheets("Foglio1")
sDate = .Range("B2")
If Weekday(sDate, vbMonday) <> 1 Then
sDate = DateAdd("d", 7 - Weekday(sDate, vbMonday) + 1, sDate)
NoOfWeeks = 1
End If
eDate = .Range("B3")
End With
If sDate = eDate Then
NoOfWeeks = NoOfWeeks + 1
Else
NoOfWeeks = NoOfWeeks + WorksheetFunction.RoundUp((eDate - sDate) / 7, 0)
End If
ReDim arr(1 To NoOfWeeks)
For i = 1 To NoOfWeeks
arr(i) = i
Next i
End Sub
Basically with my current code I would obtain an array with this ouput: arr(1, 2, 3, 4, 5, 6)
Related to this --> See Calendar
I would like to obtain: arr(11, 12, 13, 14, 15, 16, 17)
Using Application.WeekNum will be much more simple:
Option Explicit
Sub Test()
Dim StartDate As Date, EndDate As Date
With ThisWorkbook.Sheets("Foglio1") 'remember to fully qualify your ranges, including the workbook
StartDate = .Range("B2")
EndDate = .Range("B3")
End With
Dim StartWeek As Long, EndWeek As Long
StartWeek = Application.WeekNum(StartDate, 2)
EndWeek = Application.WeekNum(EndDate, 2)
Dim arr
Dim i As Long
ReDim arr(StartWeek To EndWeek)
For i = StartWeek To EndWeek
arr(i) = i
Next
End Sub
This is an alternative way:
Sub Test()
Dim StrtD As Long, EndD As Long
Dim arr As Variant
With Sheets("Foglio1")
StrtD = Application.WeekNum(.Cells(1, 2).Value, 2)
EndD = Application.WeekNum(.Cells(2, 2).Value, 2)
arr = Application.Transpose(.Evaluate("ROW(" & StrtD & ":" & EndD & ")"))
End With
End Sub
The Application.Transpose() creates an 1-D array you can call through arr(x) where x is any position within the array. You can leave the transpose if you want to create a 2-D array.
To not use .Transpose but use .Columns to return a 1-D array you can tweak the code to:
Sub Test()
Dim StrtD As Long, EndD As Long
Dim arr As Variant
With Sheets("Foglio1")
StrtD = Application.WeekNum(.Cells(1, 2).Value, 2)
EndD = Application.WeekNum(.Cells(2, 2).Value, 2)
arr = .Evaluate("COLUMN(" & .Cells(1, StrtD ).Address & ":" & .Cells(1, EndD ).Address & ")")
End With
End Sub
I guess it's a matter of preference as both ways will return an array > arr(11, 12, 13, 14, 15, 16, 17)
A run-time error occurs in the OFFSET portion of a process that finds cells with the same data in different sheets and flags the corresponding dates for those cells
I've put the offset value of the Search Cell in the String and also put it in the Range type.
Option Explicit
Option Compare Text
Sub compare()
Dim SearchRange, SearchCell, Dtt2, StdRange, StdCell As Range
Dim Dtlist As Range
Dim v1, DtCell, Dtv, Dtt, CurrDtv, FirstAddress, Standard As String
Dim r As Long
Dim maxr As Integer
Dim Dt As Date
'Dt = Worksheets("EOB").Range("H3").Value
'Dtv = DateValue(Dt)
Set Dtlist = Worksheets("2019").UsedRange.Columns("A")
Set StdRange = Worksheets("EOB").Columns("C")
Set SearchRange = Worksheets("2019").Columns("B")
maxr = Sheet2.UsedRange.Rows.Count
MsgBox "Sheet2에 있는 " & maxr & "개의 Data가 비교되었습니다"
With Sheet3.UsedRange
For r = 1 To maxr
Standard = Sheet2.Cells(r, 3).Address
Set StdCell = Worksheets("EOB").Range(Standard)
v1 = Sheet2.Cells(r, 3).Value
Set SearchCell = SearchRange.Find(v1, , xlValues, xlWhole)
DtCell = Sheet3.Cells(r, 1).Value
If Not SearchCell Is Nothing Then
FirstAddress = SearchCell.Address
Do
If SearchCell.Offset(, -1).Value <= Date And SearchCell.Offset(, -1).Value > DateAdd("m", -6, Now) Then
StdCell.Offset(, 1) = 1
ElseIf SearchCell.Offset(, -1).Value <= DateAdd("m", -6, Now) And SearchCell.Offset(, -1).Value > DateAdd("yyyy", -1, Now) Then
StdCell.Offset(, 1) = 2
Else: StdCell.Offset(, 1) = 3
End If
Set SearchCell = .FindNext(SearchCell)
Loop While Not SearchCell Is Nothing And SearchCell.Address <> FirstAddress
ElseIf SearchCell Is Nothing Then
StdCell.Interior.Color = RGB(255, 180, 180)
End If
Next
Worksheets("TEST").Range("A2") = Dtv
End With
End Sub
If SearchCell.Offset(, -1).Value <= Date And SearchCell.Offset(, -1).Value > DateAdd("m", -6, Now) Then
----->
Say 1004 runtime errors occur here
I am adding more than 10 columns to my listbox in Excel VBA. I keep getting run-time error '380'-Invalid property value. It works properly until column 9 in listbox. I couldn`t find any proper solution for this anywhere else. Does anyone know a workaround for this issue?
Private Sub txtSearch_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal
Shift As Integer)
Dim rng As Range
Set rng = Range("Lookup")
Dim rw
Dim strText As String
strText = LCase(txtSearch.Text)
With ListBox1
.RowSource = ""
.ColumnCount = 12
For Each rw In rng.Rows
If InStr(LCase(Cells(rw.Row, 4)), strText) Then
.AddItem Cells(rw.Row, 1).Value
.List(ListBox1.ListCount - 1, 1) = Cells(rw.Row, 2).Value
.List(ListBox1.ListCount - 1, 2) = Cells(rw.Row, 3).Value
.List(ListBox1.ListCount - 1, 3) = Cells(rw.Row, 4).Value
.List(ListBox1.ListCount - 1, 4) = Cells(rw.Row, 5).Value
.List(ListBox1.ListCount - 1, 5) = Cells(rw.Row, 6).Value
.List(ListBox1.ListCount - 1, 6) = Cells(rw.Row, 7).Value
.List(ListBox1.ListCount - 1, 7) = Cells(rw.Row, 8).Value
.List(ListBox1.ListCount - 1, 8) = Cells(rw.Row, 9).Value
.List(ListBox1.ListCount - 1, 9) = Cells(rw.Row, 10).Value
.List(ListBox1.ListCount - 1, 10) = Cells(rw.Row, 11).Value
.List(ListBox1.ListCount - 1, 11) = Cells(rw.Row, 12).Value
.List(ListBox1.ListCount - 1, 12) = Cells(rw.Row, 13).Value
End If
Next
End With
End Sub
I don't know if this will fix everything, but it will definitely clean it up a bit. Also, I am not sure what worksheet you are pulling Cells(rw.Row, 2).value from. But they may have something to do with why it stops part way through. Also, to clean it up a bit, try an additional For Statement.
Private Sub txtSearch_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim rng As Range: Set rng = Range("Lookup")
Dim rw
Dim strText As String: strText = LCase(txtSearch.Text)
With ListBox1
.RowSource = ""
.ColumnCount = 21
For Each rw In rng.Rows
If InStr(LCase(Cells(rw.Row, 4)), strText) Then
.AddItem Cells(rw.Row, 1).Value
For x = 1 To 12 '''Change Worksheet to your Worksheet name
.List(ListBox1.ListCount - 1, x) = Worksheets("Sample").Cells(rw.Row, x + 1).Value2
Next x
End If
Next
End With
End Sub
If this doesn't help, try what #Cyril said with the array.
Just came back to you... a bit long, but here's the general thoughts...
This all goes in the code for the ActiveX Control:
Option Explicit
Sub ListBox1_Click()
Dim rw As Range, strtext As String
Dim arr As Variant, ai As Long, aj As Long
Dim brr As Variant, bi As Long, bj As Long
strtext = "a" 'I used this when i did my testing
ReDim arr(11, 0)
For Each rw In Range("rng")
If InStr(LCase(rw.Value), strtext) Then
aj = findaj(arr)
If Not IsEmpty(arr(1, aj)) Then
aj = aj + 1
ReDim Preserve arr(11, aj)
End If
For ai = 1 To 11
arr(ai, aj) = Cells(rw.Row, ai + 1).Value
Next ai
End If
Next rw
ReDim brr(aj, 11)
For bi = 0 To aj
For bj = 1 To 11
brr(bi, bj) = arr(bj, bi)
Next bj
Next bi
ListBox1.ColumnCount = 11
ListBox1.List = brr
End Sub
Private Function findaj(ByVal brr As Variant)
Dim j As Long, meow As String
j = 0
Do While True
On Error GoTo toll
j = j + 1
meow = brr(1, j)
Loop
toll:
findaj = j - 1
End Function
So there's a lot going on here... I use two separate arrays, due to how redimming arrays works in VBA. You can only update the second element of the array, so arr(ai,aj) can only have aj updated when I redim preserve while adding a new row to my array.
So we make an array (arr) that captures the data based on VBA's limitations. Within that array, we use a function, findaj, which intentionally traps an error to determine the appropriate last column in arr (i italicized the use of column, as it's not truly the case, but it makes sense spatially when thinking about it).
You then convert the array arr to brr in the appropriate order of columns/rows.
Afterwards, you make your .list = brr.