i am sort of novice with VBA. i am trying to work with 2 listboxes, listbox1 (.lstdatabase) and listbox2 (.lstdatabase1). what i am trying to do is, when i click update cost button, selected rows from listbox1 (.lstdatabse) transfer to listbox2 (.lstdatabase1). while doing this it only transfers column 1 to 4 from listbox1 as required.
I have manage to work above by suing codes. Now, I am struggling to populate listbox2 (.lstdatabase1) column 5 (this value is from worksheet (Cost)) based on value reference to column 4 in listbox2 (.lstdatabase1).
Codes I have as below,
Private Sub cmdcostupdates_Click()
With UserForm1.lstdatabase1
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("cost")
.ColumnCount = 10
.ColumnHeads = True
.ColumnWidths = "40,60,60,60,60,100,100,250,80,80"
Dim i As Integer
For i = 0 To UserForm3.lstDatabase.ListCount - 1
If UserForm3.lstDatabase.Selected(i) = True Then
UserForm1.lstdatabase1.AddItem
UserForm1.lstdatabase1.Column(0, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(0, i)
UserForm1.lstdatabase1.Column(1, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(1, i)
UserForm1.lstdatabase1.Column(2, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(2, i)
UserForm1.lstdatabase1.Column(3, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(3, i)
UserForm1.lstdatabase1.Column(4, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(4, i)
UserForm1.lstdatabase1.Column(5, (UserForm1.lstdatabase1.ListCount - 1)) = Application.WorksheetFunction.VLookup(.List(3, i), Sheets("sh").Range("A1:G1000"), 7, False)
Can someone help to correct code for vlookup? below code gives me error.
UserForm1.lstdatabase1.Column(5, (UserForm1.lstdatabase1.ListCount - 1)) = Application.WorksheetFunction.VLookup(.List(3, i), Sheets("sh").Range("A1:G1000"), 7, False)
Found the code,
Private Sub cmdcostupdates_Click()
Dim i As Long, n As Long, f, f1 As Range
r As Rang
With UserForm1.lstdatabase1
.ColumnCount = 10
.ColumnHeads = True
.ColumnWidths = "40; 60; 60; 60; 200; 100; 100; 250; 80; 80"
For i = 0 To UserForm3.lstDatabase.ListCount - 1
If UserForm3.lstDatabase.Selected(i) = True Then
.AddItem
n = .ListCount - 1
.Column(0, n) = UserForm3.lstDatabase.Column(0, i)
.Column(1, n) = UserForm3.lstDatabase.Column(1, i)
.Column(2, n) = UserForm3.lstDatabase.Column(2, i)
.Column(3, n) = UserForm3.lstDatabase.Column(3, i)
.Column(4, n) = UserForm3.lstDatabase.Column(5, i)
Set f = Sheets("cost").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
Set f1 = Sheets("cost1").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
Set r = Sheets("cost2").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
If Not f Is Nothing Then
.Column(5, n) = Sheets("cost").Range("I" & f.Row)
End If
If Not f1 Is Nothing Then
.Column(6, n) = Sheets("cost1").Range("I" & f1.Row)
End If
If Not r Is Nothing Then
.Column(7, n) = Sheets("cost2").Range("I" & r.Row)
End If
End If
Next i
UserForm1.Show
End With
End Sub
Related
Lets say I have 10 000 rows with 4 countries and I want to color entire row based on Country.
Number of countries might change so I want to keep this dynamic.
Excel File - Unique Country Values.
| Country |
| ------- |
| SWEDEN |
| FINLAND |
| DENMARK |
| JAPAN |
Firstly I do dictionary to get unique country values with code below.
data = ActiveSheet.UsedRange.Columns(1).value
Set dict = CreateObject("Scripting.Dictionary")
For rr = 2 To UBound(data)
dict(data(rr, 1)) = Empty
Next
data = WorksheetFunction.Transpose(dict.Keys())
colors_amount = dict.Count
Then I want to generate random color for each country.
Set dict_color = CreateObject("Scripting.Dictionary")
For k = 1 To colors_amount
myRnd_1 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_2 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_3 = Int(2 + Rnd * (255 - 0 + 1))
color = myRnd_1 & "," & myRnd_2 & "," & myRnd_3
dict_color.Add Key:=color, Item:=color
Next
data_color = WorksheetFunction.Transpose(dict_color.Keys())
Now it is time to create an array which combines country and color.
For k = 0 To colors_amount - 1
varArray(k, 0) = data(k + 1, 1)
varArray(k, 1) = data_color(k + 1, 1)
Next k
And now crucial part, making loop which assigns color to entire row based on country
I have no idea how to get proper color value based on Kom Value, below description what I want to do
For Each Kom In Range("A2:A" & lastrow)
'Lets Say Kom Value is Japan so I want to take from array particular RGB Color code and put it on entire row
'I want to connect to array and do VLOOKUP how can I do it ?
Next Kom
Do you have some ideas ?
Please, test the next updated code. It uses two dictionaries and should be fast, even for large ranges creating union ranges (as dictionary keys) to be colored at once, at the end of the code. It creates RGB colors:
Sub colorsToDict()
Dim myRnd_1 As Long, myRnd_2 As Long, myRnd_3 As Long
Dim sh As Worksheet, Color As Long, Data, k As Long
Dim dict As Object, dict_color As Object
Set sh = ActiveSheet
Data = sh.UsedRange.Columns(1).Value
'place unique countries in a dictionary as keys and respective range as item
Set dict = CreateObject("Scripting.Dictionary")
For k = 2 To UBound(Data)
If Not dict.Exists(Data(k, 1)) Then
Set dict(Data(k, 1)) = sh.Range("A" & k)
Else
Set dict(Data(k, 1)) = Union(dict(Data(k, 1)), sh.Range("A" & k))
End If
Next
'place colors in the dictionary item, with the same key as in above dict
Set dict_color = CreateObject("Scripting.Dictionary")
For k = 0 To dict.count - 1
myRnd_1 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_2 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_3 = Int(2 + Rnd * (255 - 0 + 1))
Color = RGB(myRnd_1, myRnd_2, myRnd_3)
dict_color.Add key:=dict.keys()(k), Item:=Color
Next
'Place appropriate colors in the specific Union ranges:
For k = 0 To dict.count - 1
Intersect(dict.Items()(k).EntireRow, sh.UsedRange).Interior.Color = dict_color.Items()(k)
Next k
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it
Problem solved.
I made an extra array and final loop looks like this:
ReDim varArrayv2(colors_amount - 1, 0)
For kk = 0 To colors_amount - 1
varArrayv2(kk, 0) = varArray(kk, 0)
Next kk
Final loop
For Each Kom In Range("A2:A" & lastrow)
abc = Kom.value
pos = Application.Match(abc, varArrayv2, False)
color_use = varArray(pos - 1, 1)
nr1_przecinek = InStr(1, color_use, ",")
nr2_przecinek = InStr(1 + nr1_przecinek, color_use, ",")
nr2_nawias = InStr(1 + nr1_przecinek, color_use, ")")
Kolor1 = Mid(color_use, 5, nr1_przecinek - 5)
Kolor2 = Mid(color_use, nr1_przecinek + 1, nr2_przecinek - nr1_przecinek - 1)
Kolor3 = Mid(color_use, nr2_przecinek + 1, nr2_nawias - nr2_przecinek - 1)
Kom.EntireRow.Interior.color = RGB(Kolor1, Kolor2, Kolor3)
Next Kom
This can be done with a single dictionary and using autofilter:
Sub tgr()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set to correct sheet
Dim rData As Range: Set rData = ws.UsedRange.Columns(1)
Dim aData As Variant
If rData.Cells.Count = 1 Then
MsgBox "ERROR: No data found in " & rData.Address(External:=True)
Exit Sub
Else
aData = rData.Value
End If
Dim hUnq As Object: Set hUnq = CreateObject("Scripting.Dictionary")
hUnq.CompareMode = vbTextCompare 'Make dictionary ignore case for matches (example: JAPAN = japan)
'Remove any previous coloring
rData.EntireRow.Interior.Color = xlNone
Dim i As Long
For i = 2 To UBound(aData, 1) 'Start at 2 to skip header
If Not hUnq.Exists(aData(i, 1)) Then 'Found a new unique value
hUnq(aData(i, 1)) = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
With rData
.AutoFilter 1, aData(i, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Interior.Color = hUnq(aData(i, 1))
.AutoFilter
End With
End If
Next i
End Sub
Thanks for your helps,
I have two arrays: A (100k row, 10 col) and B (100k row, 12 col)
The following code (thanks to BSALV) loop through A and B => It takes really long to finish. Is there any way to speedup.
ReDim Preserve B(1 To UBound(B), 1 To UBound(B, 2) + 4)
ReDim arr(1 To UBound(B), 1 To 2)
For i = 1 To UBound(B)
iSell = B(i, 3): mysold = 0
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
If IsNumeric(r) Then
For i1 = r To UBound(A)
If A(i1, 2) = B(i, 2) And A(i1, 1) <= B(i, 1) Then
x = Application.Max(0, Application.Min(A(i1, 3), iSell))
If x > 0 Then
mysold = mysold + x
iSell = iSell - x
MyValueSold = MyValueSold + x * A(i1, 4)
A(i1, 3) = A(i1, 3) - x
If A(i1, 3) <= 0 Then A(i1, 2) = "~"
End If
If A(i1, 3) > 0 Then Exit For
End If
Next
End If
arr(i, 1) = mysold: arr(i, 2) = MyValueSold
Next
This operation is really slow when using larger arrays:
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
You can get much better performance just by replacing the Index/Match line with a dictionary lookup.
To illustrate:
Sub Tester()
Const NROWS As Long = 100000
Dim i As Long, r, t
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim A(1 To NROWS, 1 To 10)
'populate some dummy data
For i = 1 To UBound(A, 1)
A(i, 2) = Application.RandBetween(1, NROWS)
A(i, 3) = i
Next i
'First your existing row lookup...
t = Timer
For i = 1 To 100 'only testing 100 lookups (too slow for more!)
r = Application.Match(i, Application.Index(A, 0, 2), 0)
Next i
Debug.Print "Index/Match lookup", Timer - t, "*100* lookups"
'populate a dictionary for lookups...
t = Timer
For i = 1 To NROWS
dict(A(i, 2)) = i 'mapping second column first occurences to row #
Next i
Debug.Print "Mapping done", Timer - t
'Now the dictionary lookup
t = Timer
For i = 1 To NROWS
If dict.Exists(i) Then
r = dict(i)
End If
Next i
Debug.Print "Dictionary lookup", Timer - t, NROWS & " lookups"
End Sub
Output:
Index/Match lookup 9.62 *100* lookups '<<< slow slow!
Mapping done 0.12
Dictionary lookup 0.26 100000 lookups
EDIT: changes in your existing code
Dim rngMatch As Range '<<< added
'...
'...
Set lo = Sheets("Exc").ListObjects("TBL_Buy")
Set rngMatch = lo.DataBodyRange.Columns(2) '<<< lookup range
With lo.Range
.Sort .Range("B1"), xlAscending, , .Range("A1"), xlAscending, Header:=xlYes
aBuy = lo.DataBodyRange.Value2
.Sort .Range("A1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes
End With
'...
For i = 1 To UBound(aResult)
'...
r = Application.Match(aResult(i, 2), rngMatch, 0) '<<<
'...
'...
this is part of my code that i am working with and I have one problem. I have array with values (masyvas) and i started new loop to find other values by using masyvas(i,1) values and after that i need that new values would be printed in masyvas(i,2) and i need to group them. It need to look like this:
991988 Gaz.duon.sk"Giros"gaiv.g.1,5L 5_PETØFLAT1,5
PALINK
117388 Silp.gaz.nat.min.v"Tiche'1,5L 5_PETØFLAT1,5
PALINK
RIMI LIETUVA
ŠIAULIŲ TARA
111388 Gaz.nat.min.v"Tiche" 1,5L pet 5_PETØFLAT1,5
PALINK
AIBĖS LOGISTIKA
AIBĖS LOGISTIKA
RIMI LIETUVA
ŠIAULIŲ TARA
How it looks now from marked 1 it goes wrong
Data sheet where i get array values
Here is part of my code where i have this problem now it prints new values next to masyvas(i,2) but not below as I need.
lastrow2 = Sheets("lapas").Cells(Rows.Count, 1).End(xlUp).Row
rub = lastrow2
cub = 3
ReDim masyvas(1 To rub, 1 To cub)
For i = 1 To rub
For j = 1 To cub
masyvas(i, j) = Sheets("lapas").Cells(i, j).Value 'array gets values from filtered data in AKCIJOS sheet
Next
Next
Sheets("lapas").Range("A1:C100").Clear
For i = 1 To rub Step 1
Set rng2 = grafikas.Cells(6 + h, 2)
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
grafikas.Cells(7 + r, 2).EntireRow.Select
Selection.Insert Shift:=xlDown
grafikas.Cells(7 + r, 3) = akcijos.Cells(m, 3)
r = r + 1
h = r
End If
End If
Next m
For j = 1 To cub Step 1
rng2.Offset(i - 1, j - 1).Value = masyvas(i, j)
Next
Next
You didn't provide any screenshot of your data, so it's hard to say what exactly is your problem and desired output, but try the code below. I marked changed lines.
For i = 1 To rub
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
'masyvas(i, 2) = masyvas(i, 2) & akcijos.Cells(m, 3)
masyvas(i, m) = masyvas(i, m) & akcijos.Cells(m, 3) '<------
End If
End If
Next
For j = 1 To cub
rng2.Offset(j - 1, i - 1).Value = masyvas(i, j) '<-----
Next
Next
I am putting data in my array I created in VBA.
I wrote some formulas in the macro but when I paste them it is not working.
Sub Button3_Click()
Application.Calculation = xlManual
'update list of document
'declare variables
Dim i As Long
Dim m As Long
Dim n As Long
Dim j As Long
Dim lNumColumn As Long
Dim XLsheetD As String
Dim range_data As String
Dim tab_data()
Dim Data As ListObject
Dim track_list As ListObject
'ini Data
Set Data = Sheets("track_list").ListObjects("sheets_list")
Set track_list = Sheets("track_list").ListObjects("track_list")
Application.Goto Reference:=track_list
Column = ActiveCell.Column
Row = ActiveCell.Row - 1
range_data = "A9:A6000"
'import list
m = Data.ListRows.Count
nb_docs_prev = 0
n = 0
lNumColumn = Application.CountA(Sheets("track_list").Range("B6:Z6"))
For k = 1 To lNumColumn
If Range("B6").Offset(0, k - 1) = "manual" Then
GoTo nextcol
End If
n = 0
For i = 1 To m
XLsheetD = Data.DataBodyRange(i, 1)
lNumCases = Application.CountA(Sheets(XLsheetD).Range(range_data))
nb_docs = lNumCases - 1
c = Data.DataBodyRange(i, k + 1)
If c = "-" Then
n = n + lNumCases
GoTo nextsheet
End If
If k = 1 Then
ReDim Preserve tab_data(lNumColumn, nb_docs + nb_docs_prev + 1)
End If
For j = 0 To nb_docs
If Range("B6").Offset(0, k - 1) = "hyperlink" Then
tab_data(k - 1, n) = ""
Else
tab_data(k - 1, n) = Sheets(XLsheetD).Range("A9").Offset(j, c - 1)
End If
n = n + 1
Next j
nb_docs_prev = nb_docs + nb_docs_prev + 1
nextsheet:
Next i
nextcol:
Next k
'Put data in order
lNumCases = track_list.ListRows.Count
'==>test if data already in the table
For p = 1 To n
For q = 1 To lNumCases
If track_list.DataBodyRange(q, 1) = tab_data(0, p - 1) Then
For r = 1 To lNumColumn
If Range("B6").Offset(0, r - 1) = "manual" Or Range("B6").Offset(0, r - 1) = "semi-automatic" Then
If tab_data(r - 1, p - 1) <> "" Then
Else
tab_data(r - 1, p - 1) = track_list.DataBodyRange(q, r).Formula
End If
End If
Next r
End If
Next q
Next p
' formulas for new lines
For p = 1 To n
tab_data(5 - 1, p - 1) = "=IF([#[DCN no]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCN no]],DCN!R9C1:R229C1,0)),"""")"
tab_data(11 - 1, p - 1) = "=IF([#[DCN no]]<>"""",IF(INDEX(DCN!R9C7:R229C7,MATCH([#[DCN no]],DCN!R9C1:R229C1,0))<>"""",""CLOSED"",""OPEN""),"""")"
Next p
'paste list
Application.Goto Reference:=track_list
Selection.ClearContents
track_list.Resize Range(Cells(Row, Column), Cells(Row + n, Column + track_list.ListColumns.Count - 1))
Application.Goto Reference:=track_list
Selection = Application.Transpose(tab_data())
Application.Calculation = xlAutomatic
End Sub
Do you know why ?
Before doing that my macro was working. It is just those formulas impossible to paste.
Thanks
Your statement
Range("S8:AY250") = Application.Transpose(tab_data())
Can only be used to write the values of tab_data to the worksheet
You need to explicitly write your array formula to the worksheet via the method Bruce Wayne identified.
Range("S8").formulaArray = "=IF([#[DCNno]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCNno]],DCN!R9C1:R229C1,0)),"""")"
Will get you closer to where you want to be, but the above cell reference is undoubtedly wrong, and I can't determine which cell you actually need, since you're using variables in your array elements
I am trying to go through an array to find duplicate entries in a single column of that array and delete the entire row.
I am getting figuring out rangeStart, rangeEnd, and lastrow above this and that part is working fine.
data = Range(rangeStart, rangeEnd)
For i = lastrow - 1 To 2 Step -1
If data(i - 1, x) = data(i, x) Then
'Delete data(i)
End If
Next
Any help with this would be awesome!
Sub RemoveDups()
Const COMPARE_COL as Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Selection.Value
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Chr(0)
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Selection.Value = aNew
End Sub
Does this help?:
If data(i - 1, x) = data(i, x) Then
data(i,x).EntireRow.Delete
End If
Why not use Excel's inbuilt Unique options (Data ... Remove Duplicates)?
Another efficient VBA method is to use a Dictionary.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub