REPOST from my question yesterday.
Complete code below:
I think the problem is at .Column = MyArray where I send the values into the Listbox thru .column instead of .additem. But i can't figure out how to .additem an array.
Option Explicit
Dim MyArray As Variant
Dim n As Integer
Private Sub UserForm_initialize()
n = 0
End Sub
Private Sub FBcv_aDD_Click()
ReDim MyArray(4, n)
Dim i As Long
'============================================
If ListBox_FB.ListIndex = True Then
MyArray(0, n) = "Cavity Fixing Block"
MyArray(1, n) = FBcv_L.Value & " x " & FBcv_W.Value & " x " & FBcv_T.Value
If FBcv_Qty <= 1 Then
MyArray(2, n) = FBcv_Qty.Value & "pc."
ElseIf FBcv_Qty > 1 Then
MyArray(2, n) = FBcv_Qty.Value & "pcs."
End If
MyArray(3, n) = FBmat.Value
MyArray(4, n) = FBcv_uPRICE.Value
n = n + 1
End If
'============================================
With ListBox_FB
For i = 0 To ListBox_FB.ListCount - 1
If ListBox_FB.ListIndex = False Then
.AddItem ListBox_FB.List(i, 0)
ListBox_FB.List(ListBox_FB.ListCount - 1, 1) = ListBox_FB.List(i, 1)
ListBox_FB.List(ListBox_FB.ListCount - 1, 2) = ListBox_FB.List(i, 2)
ListBox_FB.List(ListBox_FB.ListCount - 1, 3) = ListBox_FB.List(i, 3)
ListBox_FB.List(ListBox_FB.ListCount - 1, 4) = ListBox_FB.List(i, 4)
End If
Next i
.ColumnCount = 5
.TextAlign = 1
.Column = MyArray
End With
End Sub
Sorry I had to repost this, i messed up with my first question.
Can anyone help me sort this out?
Any help is highly appreciated. Thanks in advanCce.
Related
My macro goes through all data rows on a specific sheet. Currently there are 6 rows. The first row is a negative number and the 2nd row is a positive number (debit and credit).
The macro reviews each row and displays a list box for the user to make a selection. Then it goes through the next row and does the same thing. I'm expecting the listbox to display 6 times, once for each row of data.
The problem I'm having is that the listbox is displaying 7 times. 3 times for the first pair or records and twice for the remaining pair of records. I can't figure out why the listbox is displaying the extra time.
Here is the code for the list box:
Private Sub ContinueButton_Click()
If IsNull(ListBox1.Value) Then
MsgBox " Please select the appropriate balance to continue. "
Exit Sub
Else
MyIndex = 0
MyIndex = ListBox1.ListIndex
MyIndex = MyIndex + 1
MyBal = ""
MyBal = APIARArray(MyIndex, 4)
Unload UserForm1
UserForm1.Hide
Sleep 750
End If
End Sub
Private Sub UserForm_Initialize()
UserForm1.Label1.Caption = "Please select the appropriate balance for Unit: " & vUnit
ListBox1.ColumnCount = 4
ListBox1.ColumnWidths = "50;50;75;50"
Dim i As Integer
With ListBox1
w = 1
i = 0
For w = 1 To UBound(APIARArray)
DoEvents
.AddItem
.List(i, 0) = APIARArray(w, 1)
.List(i, 1) = APIARArray(w, 2)
.List(i, 2) = APIARArray(w, 3)
.List(i, 3) = format(APIARArray(w, 4), "#,##0.00;[Red](#,##0.00)")
i = i + 1
Next
End With
UserForm1.Height = 215
UserForm1.Width = 348
ListBox1.SetFocus
End Sub
This is the code that calls the ListBox:
Sub LookForBalance()
Dim r As Integer
Dim APIUnit As String
r = 2
Do Until Len(Trim(Cells(r, 1))) + Len(Trim(Cells(r, 7))) + Len(Trim(Cells(r, 9))) + Len(Trim(Cells(r, 10))) + Len(Trim(Cells(r, 11))) = 0
DoEvents
If Trim(Cells(r, 27)) = "A199" Then
If Cells(r, 29) > 90 Then
APIUnit = ""
vUnit = ""
vUnit = Trim(Cells(r, 11))
If MyCntry = "A1" Then APIUnit = clsAPI.APIARSearch("WWW11", Trim(Cells(r, 11)))
If MyCntry = "A2" Then APIUnit = clsAPI.APIARSearch("WWW12", Trim(Cells(r, 11)))
If InStr(1, APIUnit, "ERROR") > 0 Then
Cells(r, 30) = "Unit Not Found"
Else
If UBound(APIARArray) > 1 Then
Load UserForm1
UserForm1.Show
Cells(r, 30) = MyBal
Else
Cells(r, 30) = APIARArray(1, 4)
End If
End If
End If
End If
r = r + 1
Loop
End Sub
There isn't much code here but I'm not sure what is going on. Any help or suggestions to resolve this issue would be greatly appreciated. Thanks in advance for your help.....
I have a list of data displayed on a listbox, after clicking on a button the list appears on my userform.
I have dates on column 2 of my list, I want to do a descending sorting.
I have the code bellow but it's not working, am I wrong ?
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
For i = 2 To fin_col_Form_Init
UF_Profil_Edit1.ListBox_Form_Init.AddItem Ws.Cells(6, i)
UF_Profil_Edit1.ListBox_Form_Init.List(UF_Profil_Edit1.ListBox_Form_Init.ListCount - 1, 1) = Ws.Cells(7, i)
Next i
Dim y, x As Integer
Dim MyList As Variant
With UF_Profil_Edit1.ListBox_Form_Init
For y = 0 To .ListCount - 1
For x = y To .ListCount - 1
If CDate(.List(x, 1)) > CDate(.List(y, 1)) Then
For c = 0 To 2
MyList = .List(x, c)
.List(x, c) = .List(y, c)
.List(y, c) = MyList
Next c
End If
Next x
.List(y, 2) = Format(.List(y, 2), "####.00")
Next y
End With
Try the next code, please:
Sub testSortListBox()
Dim i As Long, j As Long, sTemp As Date, sTemp2 As String, SortList As Variant
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
'Store the list in an array to be sorted:
SortList = UF_Profil_Edit1.ListBox_Form_Init.List
'Sort the array on the second column
For i = LBound(SortList, 1) To UBound(SortList, 1) - 1
For j = i + 1 To UBound(SortList, 1)
If CDate(SortList(i, 1)) < CDate(SortList(j, 1)) Then
'Swap the second value
sTemp = SortList(i, 1)
SortList(i, 1) = SortList(j, 1)
SortList(j, 1) = sTemp
'Swap the first value
sTemp2 = SortList(i, 0)
SortList(i, 0) = SortList(j, 0)
SortList(j, 0) = sTemp2
End If
Next j
Next i
'Remove the contents of the listbox:
UF_Profil_Edit1.ListBox_Form_Init.Clear
'Load the sorted array in the list box:
UF_Profil_Edit1.ListBox_Form_Init.List = SortList
End Sub
But, please note: The list box in discussion must not be linked to a range (not being load by its RowSource property...
I have a very large Dataset ~ 100000 rows with 2 columns, I want to calculate a rolling count based on 2 criterias, basically how many times value in col 1 wrt col 2.
Dataset looks like this
I have written the following code
This is partial dataset, actual has 100000 rows, I want the answer in col c
Sub test()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim id, data_week, ans, a As Variant
Dim p As Double
a = 100000
Debug.Print Now()
id = Sheet1.Range("A2:A" & a).Value
data_week = Sheet1.Range("B2:B" & a).Value
ans = Sheet1.Range("c2:c" & a).Value
For p = 1 To a
ans(p, 1) = Application.WorksheetFunction.CountIfs(Sheet1.Range("A2:A" & p + 1), id(p, 1),
Sheet1.Range("b2:b" & p + 1), data_week(p, 1))
Next p
Sheet1.Range("c2:c" & a).Value = ans
Debug.Print Now()
Application.Calculation = xlCalculationAutomatic
End Sub
This is taking awfully long in VBA, wondering if there's a faster way to do it interms optimising the code, appreciate your help.
Try. This takes 3 seconds to run.
Sub test3()
Dim vDB, ans()
Dim Ws As Worksheet
Dim a As Long
Dim i As Long, id, myDay
Dim n As Integer
Set Ws = Sheets(1)
a = 100000
Debug.Print Now()
With Ws
vDB = .Range("a2", .Range("b" & a))
ReDim ans(1 To UBound(vDB, 1), 1 To 1)
id = vDB(1, 1)
myDay = vDB(1, 2)
For i = 1 To UBound(vDB, 1)
If vDB(i, 1) <> "" Then
If id = vDB(i, 1) And myDay = vDB(i, 2) Then
n = n + 1
ans(i, 1) = n
Else
id = vDB(i, 1)
myDay = vDB(i, 2)
n = 1
ans(i, 1) = n
End If
End If
DoEvents
Next
.Range("c2").Resize(UBound(ans)) = ans
End With
Debug.Print Now()
End Sub
I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub
I tried to write the followings to transfer the data from one workbook to another one, however, it gets the error 9 that is out of script range. I've checked twice and could not locate any mistakes. Could you help to check to see whether I have missed anything or something is wrong? Thanks a lot.
Private Sub Transfer_Click()
Application.ScreenUpdating = False
Sheets("List").Select
v = Range("A2").End(xlDown).Row
Dim a()
Dim b()
ReDim a(v - 1)
ReDim b(v - 1)
Sheets("Yahoo").Select
For i = 0 To v - 1
a(i) = Cells(i + 7, 4)
b(i) = Cells(i + 7, 5)
Next
ChDir "C:\Users\Desktop\Data Analysis"
Workbooks.Open Filename:="C:\Users\Desktop\Data Analysis\Data.xlsx"
Sheets("List").Select
For i = 2 To Range("A1").End(xlDown).Row
Sheets("List").Select
k = Cells(i, 1)
If k = "" Then Exit For
Sheets(k).Select
h = Range("B8").End(xlDown).Row
Cells(h + 1, "B") = a(i - 2)
Cells(h + 1, "F") = b(i - 2)
Next
Windows("Data.xlsm").Activate
Sheets("Yahoo").Select
Application.CutCopyMode = False
Workbooks("Data.xlsx").Save
Workbooks("Data.xlsx").Close
Application.ScreenUpdating = True
MsgBox "Successfully transferred!", vb0XOnly, "Notice"
End Sub