An analyst observed that the upward movement of stocks on Bovespa is repeated according to a mathematical sequence. He wants to find out what the next bullish sequences will be. Generate and save in Excel cells using macro the sequence 1, 3, 4, 7, 11, 18, 29, ... up to its twentieth term?
following my code in vba:
Sub GerarSequencia()
Dim num As Long
Dim previous As Long
Dim i As Integer
num = 0
previous = 0
For i = 1 To 20
If i = 1 Then
num = 1
Else
num = num + previous
End If
Cells(i, 1).Value = num
previous = num
Next i
End Sub
I tried to generate the sequence of the exercise but did it generate another one?
The sequence is a sommation of the earlier two values. So 1 + 3 = 4 and so on. Before you can start the sqequence you have to have two numbers. I think you can work with:
Sub GerarSequencia()
Dim intFirstNum, intSecondNum As Integer
Dim intCounter As Integer
intFirstNum = 1
intSecondNum = 3
Cells(1, 1) = intFirstNum
Cells(2, 1) = intSecondNum
For intCounter = 3 To 20
Cells(intCounter, 1).Value = Cells(intCounter - 2, 1).Value + Cells(intCounter - 1, 1).Value
Next intCounter
End Sub
So you see that I have made two additional variables which are filled with 1 and 3 (if you change them you can start wherever you want). From that point on, I start the loop from position 3. This is because the first two are already known.
From that point on you can run the sequence. You don't need an if statement in that case.
Generating a Sequence
Sub GerarSequencia()
Const nCOUNT As Long = 20
Dim nPrev As Long: nPrev = 1
Dim nCurr As Long: nCurr = 3
Cells(1, 1).Value = nPrev
Cells(2, 1).Value = nCurr
Dim nNext As Long
Dim i As Long
For i = 3 To nCOUNT
nNext = nPrev + nCurr ' sum up
Cells(i, 1).Value = nNext ' write
nPrev = nCurr ' swap
nCurr = nNext ' swap
Next i
' ' Return the worksheet results in the Immediate window (Ctrl + G).
' For i = 1 To 20
' Debug.Print Cells(i, 1).Value
' Next i
End Sub
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
End Sub
I am trying to set up my user form to do a loop or look up to reference my table which is on a sheet and is a large data base.
I want my user form to look up what I type and then auto fill in the other textboxes so that I can limit the number of duplicates and make it more stream lined.
My code is as shown below is embedded into Textbox1 and is set up to run the code after change. It is still not working and I have worked for many days and weeks trying to figure this out.
Option Explicit
Dim id As String, i As String, j As Integer, flag As Boolean
Sub GetDataA()
If Not IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 7
UserForm1.Controls("TextBox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 5 To 10
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
End If
End Sub
you may want to adopt this refactoring of your code
Option Explicit
Sub GetDataA()
Dim j As Integer
Dim f As Range
With UserForm1 '<--| reference your userform
If Not IsNumeric(.TextBox1.Value) Then Exit Sub '<--| exit sub if its TextBox1 value is not a "numeric" one
Set f = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Find(what:=.TextBox1.Value, LookIn:=xlValues, lookat:=xlWhole) '<--| try and find its TextBox1 value along column "A" cells from row 1 down to last not empty one
If f Is Nothing Then '<--| if not found
For j = 5 To 10
.Controls("TextBox" & j).Value = ""
Next j
Else '<--| if found
For j = 2 To 7
.Controls("TextBox" & j).Value = f.Offset(, j - 1).Value
Next j
End If
End With
End Sub
note: if this sub is actually inside UserForm1 code pane than you can change With UserForm1 to With Me
i need some help with search function with this, how can i convert this that userform will search other sheet of my workbook
name of other sheet is "DataSource"
im planning to separate the data into another sheet of workbook then define a name and i will make it as offset so inshort whenever i put another data it will be able to search with the use of my search userform
This is my code
Sub GetData()
Dim id As Integer, i As Integer, j As Integer, flag As Boolean
If IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 3
UserForm1.Controls("TextBox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 2 To 3
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
ClearForm
End If
End Sub
This is my code for editing data
Sub EditAdd()
Dim emptyRow As Long
If UserForm1.TextBox1.Value <> "" Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 3
Cells(i + 1, j).Value = UserForm1.Controls("TextBox" & j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 1 To 3
Cells(emptyRow, j).Value = UserForm1.Controls("TextBox" & j).Value
Next j
End If
End If
End Sub
This is defined name of Datasource sheet
Name: data
=OFFSET(DataSource!$A:$A,1,0,COUNTA(DataSource!$A:$A)-1,1)
I have a table with three columns,
ID, Name and Date
then I create a userform with textbox ID and Name.
how could I display the Name of similar ID from the table with latest Date when I key in the ID in the userform? (similar ID will have different names, but I want to display the one with latest date in the table)
thanks in advance for all the help
coding for the textbox1
Private Sub TextBox1_Change()
getdata
End Sub
coding for the getdata module
Sub getdata()
If IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 3
UserForm1.Controls("textbox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 2 To 3
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
ClearForm
End If
End Sub
This should do it for you. This routine goes in your userform code module:
Private Sub TextBox1_AfterUpdate()
TextBox2 = Evaluate("=INDEX(B2:B999,MATCH(MAX((IF(A2:A999=" & TextBox1 & _
",1)*(C2:C999)),1),IF(A2:A999=" & TextBox1 & _
",1)*(C2:C999),))")
End Sub
It assumes your data are in columns A, B, and C. It also assumes your data do not extend past row 999; if they do, then increase the 999's in the formula to what is appropriate.
TextBox1 is for the ID.
TextBox2 is for the Name.
Note that this code is placed in the AfterUpdate event procedure. This is different than your sample code. You used the Change event procedure. The difference is that Change fires on each keystroke while AfterUpdate fires only after the full text is confirmed for the textbox.
Note that you should still add error checking for the case where the ID is not numeric and also for the case where the numeric ID does not match. The code above is simply for demonstrating the technique to display the looked-up value. If you wish for me to flesh it out more, please let me know.
UPDATE
I went ahead and fleshed it out with the error checking:
Private Sub TextBox1_AfterUpdate()
GetData
End Sub
Public Sub GetData()
Dim v, w
On Error Resume Next
v = Evaluate("=INDEX(B2:B999,MATCH(MAX((IF(A2:A999=" & TextBox1 & _
",1)*(C2:C999)),1),IF(A2:A999=" & TextBox1 & _
",1)*(C2:C999),))")
w = Evaluate("MAX((IF(A2:A999=" & TextBox1 & ",1)*(C2:C999)))")
If IsArray(v) Or IsError(v) Then v = "ID not found.": w = ""
TextBox2 = v
TextBox3 = "": TextBox3 = CDate(w)
End Sub
UPDATE 2
In the fleshed out version directly above, I added support for the associated date in TextBox3.
You could read the whole range in when the userform opens, sort it, then find the first ID.
Private mvaData As Variant
Private Sub TextBox1_AfterUpdate()
Me.TextBox2.Text = vbNullString
Me.TextBox3.Text = vbNullString
GetData
End Sub
Public Sub GetData()
Dim i As Long
For i = LBound(mvaData, 1) To UBound(mvaData, 1)
If mvaData(i, 1) = Val(Me.TextBox1.Text) Then
Me.TextBox2.Text = mvaData(i, 2)
Me.TextBox3.Text = mvaData(i, 3)
Exit For 'stop after the first one - largest date
End If
Next i
End Sub
Private Sub UserForm_Initialize()
Dim i As Long, j As Long
Dim lId As Long, sDesc As String, dtDate As Date
'store the data in a variable when the forms opens
mvaData = Sheet1.Range("A1:C5")
'sort with larger dates on top
For i = LBound(mvaData, 1) To UBound(mvaData, 1) - 1
For j = i To UBound(mvaData, 1)
If mvaData(i, 3) < mvaData(j, 3) Then
lId = mvaData(j, 1)
sDesc = mvaData(j, 2)
dtDate = mvaData(j, 3)
mvaData(j, 1) = mvaData(i, 1)
mvaData(j, 2) = mvaData(i, 2)
mvaData(j, 3) = mvaData(i, 3)
mvaData(i, 1) = lId
mvaData(i, 2) = sDesc
mvaData(i, 3) = dtDate
End If
Next j
Next i
End Sub