Related
I am attempting to loop through columns forecasting data in VBA. When there were 3 columns, this worked originally, I expanded to 6 columns and it is now not functioning.
I also tried a variant using a single loop for the forecasting and using Select Case to loop through all the columns.
Sub forecast_daily()
'refresh values (specifically Today and matching index)
Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
'set sheets
Set wb = ThisWorkbook.Sheets("Daily Data")
Set fc = ThisWorkbook.Sheets("Intake Forecasting Daily")
' define values
Dim dates, newdates, EUSSIntake, JFMintake, lateintake, newjfmintake, convertintake, BNOintake, Akinintake, Chenintake, ibtexintake, zambintake, velajintake As Range
Dim i, j As Long
Dim newdate As Double
Dim Rownum, a As Integer
Dim negcheck As Double
Dim toggleB, toggleC, toggleD, toggleE, toggleF, toggleG As Boolean
'Find empty row in EUSSIntake
i = fc.Range("V3").Value
'i equals empty row number
newdate = Cells(i, 1)
Set dates = Range("A22", "A" & (i - 1))
Set EUSSIntake = Range("B22", "B" & (i - 1))
'change starting point for JFM and BNO to account for blanks
Set newdates = Range("A1065", "A" & (i - 1))
Set JFMintake = Range("C1065", "C" & (i - 1))
Set BNOintake = Range("D1065", "D" & (i - 1))
'change start point for EUSS split (922)
Set dates3 = Range("A922", "A" & (i - 1))
Set lateintake = Range("E922", "E" & (i - 1))
Set newjfmintake = Range("F922", "F" & (i - 1))
Set convertintake = Range("G922", "G" & (i - 1))
' Loop Worksheet forecast function
toggleB = True
toggleC = True
toggleD = True
toggleE = True
toggleF = True
toggleG = True
' This is main loop - This originally worked! Frustrating now that it is isnt.
While i < 3001
If Cells(i - 1, 2) > -1000 And toggleB = True Then
Cells(i, 2).Value = Application.WorksheetFunction.Forecast(newdate, EUSSIntake, dates)
Else
toggleB = False
End If
If Cells(i - 1, 3) > -1000 And toggleC = True Then
Cells(i, 3).Value = Application.WorksheetFunction.Forecast(newdate, JFMintake, newdates)
Else
toggleC = False
End If
If Cells(i - 1, 4) > -1000 And toggleD = True Then
Cells(i, 4).Value = Application.WorksheetFunction.Forecast(newdate, BNOintake, newdates)
Else
toggleD = False
End If
If Cells(i - 1, 5) > -1000 And toggleE = True Then
Cells(i, 5).Value = Application.WorksheetFunction.Forecast(newdate, lateintake, dates3)
Else
toggleE = False
End If
If Cells(i - 1, 6) > -1000 And toggleF = True Then
Cells(i, 6).Value = Application.WorksheetFunction.Forecast(newdate, newjfmintake, dates3)
Else
toggleF = False
End If
If Cells(i - 1, 7) > -1000 And toggleG = True Then
Cells(i, 7).Value = Application.WorksheetFunction.Forecast(newdate, convertintake, dates3)
Else
toggleG = False
End If
' increment i
i = i + 1
' Update new values
newdate = Cells(i, 1)
Wend
End Sub
I have tried the usual reasons for this error. Newdate is passing in as a double, knownx and knowny and ranges of equal size for the forecast function. Im pulling my hair out that it worked 2 days ago and ive changed nothing and now its throwing the error.
I've tried by hours to cope with this error, search solutions, but nothing is clear for me.
I've imported successfully items from Excel to combobox (>19 appearances)
Now I have duplicates in combo. I wanna iterate by Excel sheet, compare with Combobox & remove unnecessary items (except single one)
I have
error 381 - Could not get the Column property array index.
Dim N As Long, K As Long, counter As Long
With Sheets("Główne")
N = .Cells(Rows.Count, 12).End(xlUp).Row
End With
Dim ostatnia As Long
ostatnia = Cells(Rows.Count, 11).End(xlUp).Row
For i = 1 To ostatnia
Range("I" & i + 1).Formula = "=COUNTIFS(L:L,L" & i + 1 & ")"
Next
ComboBox1.Clear
For K = 1 To N
If Cells(K + 1, 9).Value > 19 Then
ComboBox1.AddItem Sheets("Główne").Cells(K + 1, 12).Value
End If
Next K
Range("I2:I" & ostatnia).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'############### problem is somewhere below ##############'
For S = 2 To N
counter = 1
For iteracjalista = 0 To ComboBox1.ListCount - 1
If ComboBox1.Column(0, iteracjalista) = Sheets("Główne").Cells(S + 1, 12).Value Then
If Sheets("Główne").Cells(S + 1, 9).Value > counter Then
ComboBox1.RemoveItem 1
counter = counter + 1
End If
End If
Next iteracjalista
Next S
Probably problem is in last part of code. But I have no idea how I should fix it.
Could you help me?
In place of this Code
For K = 1 To N
If Cells(K + 1, 9).Value > 19 Then
ComboBox1.AddItem Sheets("Główne").Cells(K + 1, 12).Value
End If
Next K
Use this Code - It eliminates Duplicates before populating the ComboBox
Dim xList As String, xVal As String
' The following populates the ComboBox with Unique Values - No Duplicates
xList = ""
' We are using the colon character ":" as a separator
' You may wish to use something else
For K = 1 To N
xVal = Cells(K + 1, 9).Value
If xVal > 19 Then
If InStr(1, xList, ":" & xVal, vbTextCompare) = 0 Then
xList = xList & ":" & xVal
End If
End If
Next K
xList = Mid(xList, 2) ' Remove the leading : character
ThisWorkbook.Sheets("Glówne").ComboBox1.List = Split(xList, ":")
' Done
Then you can takeout all the existing code for deleting duplicates from the ComboBox .... All the following can be deleted
'############### problem is somewhere below ##############'
For S = 2 To N
counter = 1
For iteracjalista = 0 To ComboBox1.ListCount - 1
If ComboBox1.Column(0, iteracjalista) = Sheets("Główne").Cells(S + 1, 12).Value Then
If Sheets("Główne").Cells(S + 1, 9).Value > counter Then
ComboBox1.RemoveItem 1
counter = counter + 1
End If
End If
Next iteracjalista
Next S
I'm trying to make a macro that increases the time between data points as part of automatic data processing, but it currently takes way too long.
One of my sensors logs a data point every 10 seconds, I want to increase this dt to 1 hour. For this I wrote some very simple (inefficient) code (see below) that does work but takes 10-40 minutes to process 1 week of data which is far from ideal.
I've seen recommendations for semi-similar issues to use an array, however I have 0 experience with this and don't know if it's applicable to this goal.
Do While Cells(row + 1, 2).Value <> ""
If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
Rows(row + 1).Select
Selection.Delete Shift:=xlUp
Else
row = row + 1
End If
Loop
EDIT:
I solved my issue with a slightly edited version of #Damian's code as shown below.
Sub Change_dt()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long, Z As Long
x = 1
Z = 1
For i = 1 To UBound(arrSource)
On Error Resume Next
If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than target both will be copied to the final array
If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + Z, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
i = i + Z
Z = 1
Else
Z = Z + 1
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This should help a lot in your executing time:
Sub Change_dt()
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long
x = 1
For i = 5 To UBound(arrSource)
On Error Resume Next
If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + 1, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
End Sub
I search any text within Worksheet2 and display the results in ListBox1.
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
'Populating listbox from search
Dim i As Long
For i = 2 To Sheet2.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(Sheet2.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
Sheet2.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
I want to search multiple worksheets instead but don't know how to achieve this without changing the code completely.
You're going to have to change the reference to Sheet2 if you want to look at multiple sheets. There's no way around that. But, it will make your code more flexible. Start by doing this:
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
Dim ws As Worksheet 'This is the new line of code where you define your worksheet
Set ws = ActiveWorkbook.Sheet2 'Replace all references below to Sheet2 with this
'Populating listbox from search
Dim i As Long
For i = 2 To ws.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(ws.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
ws.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
Now that you're generalized your Sub, you can modify the value of ws to repeat the code as much as you need to. If it is every sheet in your workbook, you can use a For Each loop, like
For Each ws In ActiveWorkbook
'All your code for the ws here
Next ws
Or, you can define the worksheets in an array beforehand.
Dim SheetList(0 to 2) As String
Dim k As Integer
SheetList(0) = "Sheet 2 Name"
SheetList(1) = "Sheet 4 Name"
SheetList(2) = "Sheet 3 Name"
SheetList(3) = "Sheet 6 Name"
For k = LBound(SheetList) To UBound(SheetList)
ws = ActiveWorkbook.Sheets(SheetList(k))
'The rest of your code from above
Next k
You didn't specify in your question what kind of sheets how many, or how they are organized. But, these options should be enough to get you where you are trying to go.
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