I was doing a project earlier that consisted of many index/matches. I personally love nested loops, so I wanted to see if I could implement it this time around. My nested loop consists of i and j, where my third and most outer loop is my x variable, which gets placed inside my (Application.index). I've never done three loops so I'm not sure if this is possible. The error I am getting is, "application-defined or object-defined error".
Thanks,
SD
Dim i%, j%
Dim j&
Dim myArr%(0 To 5)
'myArr = Array(2, 1, 17, 18, 6, 16)
'For x = LBound(myArr) To UBound(myArr)
myArr(0) = 2
myArr(1) = 1
myArr(2) = 17
myArr(3) = 18
myArr(4) = 6
myArr(5) = 16
For x = 0 To 5
For i = 2 To shSS.Range("A1048576").End(xlUp).Row
For j = 1 To 16
Sheets("Sheet1").Cells(i, j) = Application.IfError(Application.Index(shRoster.Columns(x), Application.Match(shSS.Range("D" & i + 1), shRoster.Columns(4), 0)), "-")
If shSS.Cells(i, 11) = "Internal" Then
shCV.Cells(i, 10) = "Y"
Else
shCV.Cells(i, 10) = "N"
End If
Next j
Next i
Next x
Instead of this:
Sheets("Sheet1").Cells(i, j) = _
Application.IfError(Application.Index(shRoster.Columns(x), _
Application.Match(shSS.Range("D" & i + 1), shRoster.Columns(4), 0)), "-")
you can do something like:
Dim m
m = Application.Match(shSS.Range("D" & i + 1), shRoster.Columns(4), 0)
If Not IsError(m) Then
Sheets("Sheet1").Cells(i, j).Value = shRoster.Columns(x).Cells(m)
Else
Sheets("Sheet1").Cells(i, j).Value = "'-"
End If
Related
I am having an issue with the "Subscript out of Range" error message. I got some help writing a code that loops a long list of stocks. The code basically makes all of the vectors even so i can use it in a panel data setting.
The loop stops after 4 stocks and gives me a "Subscript out of Range" error.
I can run the code over the first 95 "i" i.e. if i transform the first part:
For i = 4 To 95
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Code:
**Sub Outer_Loop()
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row**
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Next i
End Sub
Sub Clean_Stock_2(ByVal r As Long)
Dim Stock(31, 5)
Dim Quarter(31)
Dim Bo As Boolean
Charge = 0
'Frame
For i = 0 To 31
Stock(i, 0) = Cells(r, 1)
Stock(i, 1) = Cells(r, 2)
Stock(i, 2) = Cells(r, 3)
Stock(i, 5) = "Q" & Format(DateAdd("q", i, #1/1/2011#), "q-YYYY")
Quarter(i) = Stock(i, 5)
Next i
'Data
Do While Cells(r, 1) = Stock(0, 0)
Qu = "Q" & Format(Cells(r, 4), "q-YYYY")
rr = Application.Match(Qu, Quarter, 0)
If Not IsError(rr) Then
Stock(rr, 3) = Cells(r, 4)
Stock(rr, 4) = Cells(r, 5)
If Not Bo Then Charge = Stock(rr, 4): Bo = True
End If
r = r + 1
Loop
'fill
For i = 0 To 31
If Stock(i, 4) = 0 Then
Stock(i, 4) = Charge
Else
Charge = Stock(i, 4)
End If
Next i
'Output
lr = Cells(Rows.Count, "I").End(xlUp).Row + 1
lr = IIf(lr < 3, 3, lr)
Cells(lr, "I").Resize(32, 6) = Stock
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
enter image description here[enter image description here][2]Hi,
I have an issue and hopefully someone can help. I have an Excel sheet and I Need to check if starting from last row if the same value as in column 4 from last row exists somewhere above, but condition is, that only if column 1 and column 2 are same and not in column 3 is the word "SK" or "SV" and then I Need to sum the values in column 7 and concaternate column 3 and column 6 and just Keep one line and the other which were the base of this calculation must be deleted.
Attached you will find the screenshots. First how the Excel file Looks like before processing and next screenshot how it should look like afterwards.
enter image description here
Here is the code:
Sub combine_data()
Dim vLastRow As Integer
Dim Col_A_Str As String
Dim Col_B_Str As String
Dim r As Integer
Dim vDatarow As Integer
Dim vCodeStr3 As String
Dim vCodeStr6 As String
Dim vTotal As Double
Dim Col_D_Str As String
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Col_A_Str = ""
Col_B_Str = ""
r = 1
vDatarow = 0
vCodeStr3 = ""
vCodeStr6 = ""
vTotal = 0
Col_D_Str = ""
Col_A_Str = Trim(Cells(vLastRow, 1))
Col_B_Str = Trim(Cells(vLastRow, 2))
Col_D_Str = Trim(Cells(vLastRow, 4))
Do Until r = vLastRow
DoEvents
If Trim(Cells(r, 4)) = Col_D_Str Then
If Trim(Cells(r, 1)) = Col_A_Str Then
If Trim(Cells(r, 2)) = Col_B_Str Then
If UCase(Trim(Cells(r, 3))) <> "SV" And UCase(Trim(Cells(r, 3))) <> "SK" Then
If vDatarow = 0 Then
If vDatarow = 0 Then vDatarow = r
vCodeStr3 = Trim(Cells(r, 3))
vCodeStr6 = Trim(Cells(r, 6))
vTotal = Cells(r, 7)
r = r + 1
Else
vCodeStr3 = vCodeStr3 & ", " & Trim(Cells(r, 3))
vCodeStr6 = vCodeStr6 & ", " & Trim(Cells(r, 6))
vTotal = vTotal + Cells(r, 7)
Cells(r, 1).EntireRow.Delete
vLastRow = vLastRow - 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Loop
Cells(vDatarow, 3).ClearContents
Cells(vDatarow, 3) = vCodeStr3
Cells(vDatarow, 6).ClearContents
Cells(vDatarow, 6) = vCodeStr6
Cells(vDatarow, 7).ClearContents
Cells(vDatarow, 7) = vTotal
End Sub
I have a code that takes a list of Airline flightlegs and matches them up to give me full lines of flight. The code works but..... it takes a very long time (45-60 min for just 35,000 rows) due to the amount of data it has to go through. This is compounded and the overall code takes about 2 hours to run. Is there a faster method to get the same results?
Here is my current code that really bogs down the entire process:
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim T As Long
Dim c As Long
Dim a As Long
Dim f As Long
Dim l As Long
Dim g As Long
Dim y As String
Dim b As String
Set ref = Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo nexta
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
'On Error GoTo NextI
If IsError(Application.Match(.Cells(i, 2), LegTable, 0)) Then
GoTo nexti
Else
y = Application.Match(.Cells(i, 2), LegTable, 0) + f - 1
.Cells(i, 1).End(xlToRight).Offset(0, 1).Value2 = .Cells(y, 2)
Do
'On Error GoTo NextI
If IsError(Application.Match(.Cells(y, 2), LegTable, 0)) Then
GoTo nexti
Else
b = Application.Match(.Cells(y, 2), LegTable, 0) + f - 1
h = .Cells(b, 2)
.Cells(i, 1).End(xlToRight).Offset(0, 1) = h
y = b
End If
Loop
nexti:
End If
b = ""
y = ""
Next i
nexta:
Next a
End With
End Sub
The data is all string data of about 50+ chars.
Thank you for any recomendations.
Thank you very much A.S.H. with your help, I not only learned alot about using arrays, but also ended up cutting my runtime from about 90 minutes to just over 3 minutes. This is my final working code that used a combination of your suggestions.
Sub BuildingLines()
'strings together segments into trip
Dim i As Long
Dim z As Long
Dim c As Long
Dim f As Long
Dim l As Long
Dim LegTable As Range
Dim TurnTable As Range
Dim FirstTurn() As Variant
Dim NextTurn() As Variant
Dim y As String
Dim b As String
Dim FTtext As String
Dim wb As Workbook
Dim ref As Worksheet
Set wb = ThisWorkbook
Set ref = wb.Sheets("Ref")
With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row
For a = 24 To g
If ref.Cells(a, 2) = "" Then GoTo NextA
f = ref.Cells(a, 2)
c = ref.Cells(a, 3)
l = ref.Cells(a, 4)
Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
Set TurnTable = Range(.Cells(f, 1), .Cells(l, 2))
FirstTurn = TurnTable
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=LegTable, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange TurnTable
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = f To l
Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
DoEvents
y = 0
b = 0
y = Application.Match(.Cells(i, 2), LegTable, 1)
If .Cells(i, 2) <> FirstTurn(y, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(y, 2)
Do
FTtext = FirstTurn(y, 2)
On Error GoTo errhdlr
b = Application.WorksheetFunction.Match(FTtext, LegTable, 1)
If FTtext <> FirstTurn(b, 1) Then GoTo NextI
NextLeg = NextLeg + 1
ReDim Preserve NextTurn(0, 1 To NextLeg)
NextTurn(0, NextLeg) = FirstTurn(b, 2)
y = b
Loop
errhdlr:
Resume NextI
NextI:
If NextLeg > 0 Then Range(.Cells(i, 3), .Cells(i, NextLeg + 2)).Value = NextTurn
Erase NextTurn
NextLeg = 0
Next i
Set LegTable = Nothing
Set TurnTable = Nothing
Erase NextTurn
Erase FirstTurn
NextA:
Next a
End With
End Sub
I first tried using just the arrays, but the Match function was WAY SLOWER in the arrays. So I ended up using the Match to find the index and then grabbed the data from the array to build my second array which then became my output. I can't wait to adapt my new found knowledge with the rest of this project and cut my runtime from 2+ hours to just minutes!! Thanks, again!!!
Could someone explain what is happening here? Preferably line for line. I am having a hard time wrapping my head around what is happening with this bit.
a = Application.Transpose(a)
For i = 1 To UBound(a, 2)
If UCase(a(1, i)) Like "*" & temp & "*" Or _
UCase(a(2, i)) Like "*" & temp & "*" Then
n = n + 1
For ii = 1 To UBound(a, 1)
a(ii, n) = a(ii, i)
Next
End If
Next
I am also experiencing a "type mismatch" error for the above. See full Sub below.
Private Sub TextBox_Search_Change()
Select Case True
Case OptionButton_User_Name.Value
Dim a, i As Long, ii As Long, n As Long, temp As String
If Len(Me.TextBox_Search.Value) Then
temp = UCase(Me.TextBox_Search.Value)
With Sheets("ToolData")
a = Union(.Range("B:B"), .Range("F:F"), .Range("G:G")).Value
End With
a = Application.Transpose(a)
For i = 1 To UBound(a, 2)
If UCase(a(1, i)) Like "*" & temp & "*" Or _
UCase(a(2, i)) Like "*" & temp & "*" Then
n = n + 1
For ii = 1 To UBound(a, 1)
a(ii, n) = a(ii, i)
Next
End If
Next
If n > 0 Then
ReDim Preserve a(1 To UBound(a, 1), 1 To n)
Me.ListBox_History.Column = a
End If
Else
With Sheets("ToolData")
Me.ListBox_History.List = Union(.Range("B:B"), .Range("F:F"), .Range("G:G")).Value
End With
End If
Case Else
End Select
You cannot use .Value on a multi-area range: you will only get values from the first column (B).
I would refactor the True portion of your If statement as
temp = UCase(Me.TextBox_Search.Value)
Dim rngValues As Variant
With Sheets("ToolData")
rngValues = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Resize(, 6).Value
End With
For i = 1 To UBound(rngValues, 1)
'Check columns B & F for matching values
If UCase(rngValues(i, 1)) Like "*" & temp & "*" Or _
UCase(rngValues(i, 5)) Like "*" & temp & "*" Then
'Store columns B, F & G for displaying in the ListBox
n = n + 1
ReDim Preserve a(1 To 3, 1 To n)
a(1, n) = rngValues(i, 1)
a(2, n) = rngValues(i, 5)
a(3, n) = rngValues(i, 6)
End If
Next
'If anything found, replace the ListBox contents. Otherwise leave it as it was.
If n > 0 Then
Me.ListBox_History.Column = a
End If
thus getting rid of the code which is reading into memory all 1048576 rows of your sheet, and the need of the Transpose (which won't work on large volumes of data).
You will also need to change the False leg of your If, perhaps in a similar fashion.