Related
I'm new to VBA and was surprised that there isn't a function to insert elements in an array (my previous question). So I rethought my approach a bit.
On screen I have the following example table 'allActualWeights'. There are a lot of blanks (no weight value) that I want to get rid of (the table is different everytime). So the end result should be 'actualWeights'.
In my code I tried the following:
Option Base 1
Dim allActualWeights
allActualWeights = Range("A6:E29").Value
Dim actualWeights
actualWeights = allActualWeights
For Index = 1 To 24
If allActualWeights(Index, 2) <> 0 Then
ReDim actualWeights(Index, 5)
actualWeights(Index, 1) = allActualWeights(Index, 1)
actualWeights(Index, 2) = allActualWeights(Index, 2)
actualWeights(Index, 3) = allActualWeights(Index, 3)
actualWeights(Index, 4) = allActualWeights(Index, 4)
actualWeights(Index, 5) = allActualWeights(Index, 5)
End If
Next Index
Range("G6:K29") = actualWeights
But I'm not getting the results I hoped for.
What am I doing wrong, or is there a better approach?
Here's one approach:
Sub Tester()
Dim allActualWeights, actualweights(), i As Long, n As Long, c As Long
Dim rngSource As Range
Set rngSource = ActiveSheet.Range("A6:E29")
With rngSource
allActualWeights = .Value
'size the output array # of rows to count of values in ColB
ReDim actualweights(1 To Application.CountA(.Columns(1)), _
1 To .Columns.Count)
End With
n = 1
For i = LBound(allActualWeights, 1) To UBound(allActualWeights, 1)
If Len(allActualWeights(i, 2)) > 0 Then
For c = LBound(allActualWeights, 2) To UBound(allActualWeights, 2)
actualweights(n, c) = allActualWeights(i, c)
Next c
n = n + 1 'next output row
End If
Next i
'put the array on the sheet
Range("G6").Resize(UBound(actualweights, 1), UBound(actualweights, 2)) = actualweights
End Sub
This should do it and is easily maintainable...
Sub ActualWeights()
Dim c&, i&, j&, n&, a, b
With [a6:e29] '<-- allActualWeights
a = .Value2
n = UBound(a) - Application.CountBlank(.Offset(, 1).Resize(, 1))
ReDim b(1 To n, 1 To UBound(a, 2))
For i = 1 To UBound(a)
If a(i, 2) Then
c = c + 1
For j = 1 To UBound(a, 2)
b(c, j) = a(i, j)
Next
End If
Next
.Offset(, 6).Resize(n) = b
End With
End Sub
i have the following code and am stuck as of now.
Instead of this line, i actually want to delete the row. How to do that?
cData(rw, 5) = "Matching DES found"
For rw = 1 To UBound(cData, 1)
'For Each e In cRng
For rw2 = 1 To UBound(cData, 1)
If Left(cData(rw, 1), 4) <> "DES_" Then
a = cData(rw, 3)
If Left(cData(rw2, 1), 4) = ("DES_") And Right(cData(rw2, 1), Len(a)) = a Then
cData(rw, 5) = "Matching DES found"
'cData(rw, 1) = Empty
Exit For
'GoTo nextI
Exit For
Else
cData(rw, 5) = "unique"
'GoTo nextE
End If
Else
'GoTo nextI
Exit For
End If
'nextE:
Next
'nextI:
Next
Here a solution with the use of a ListBox in memory:
(deleting backwards)
Set ListBoxData = CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}") 'Listbox
ListBoxData.List = cData
For rw = ListBoxData.ListCount - 1 To 0 Step -1
'For Each e In cRng
For rw2 = ListBoxData.ListCount - 1 To 0 Step -1
If Left(ListBoxData.List(rw, 0), 4) <> "DES_" Then
a = ListBoxData.List(rw, 2)
If Left(ListBoxData.List(rw2, 0), 4) = "DES_" And Right(ListBoxData.List(rw2, 0), Len(a)) = a Then
ListBoxData.List(rw, 4) = "Matching DES found"
ListBoxData.RemoveItem rw 'remove your row
'ListBoxData(rw, 1) = Empty
Exit For
'GoTo nextI
'Exit For
Else
ListBoxData.List(rw, 4) = "unique"
'GoTo nextE
End If
Else
'GoTo nextI
Exit For
End If
'nextE:
Next
'nextI:
Next
newcData = ListBoxData.List 'cleaned Listboxdata to a new Array, but lbound = 0 so act accordingly
I have 3 workers.
I need to make assembly line balancing.
There are 10 operations of model.
You can see the time of operations for all workers in the chart below. They have different abilities.
So I need to share all operations between 3 workers.
so what I need:
Worker and operations of model is changeable.
20 worker-25 operations
18 worker-40 operations
19 worker-75 operations
...
So I need to define parameters for all i. Maybe need to use a function?
Sub rapor_calistir()
Range("q1") = Now()
Sheets("Rapor").Range("A2:Z1048576").ClearContents
a = 2: worker1 = 0: worker2 = 0: worker3 = 0
For i1 = 1 To 3
For i2 = 1 To 3
For i3 = 1 To 3
For i4 = 1 To 3
For i5 = 1 To 3
For i6 = 1 To 3
For i7 = 1 To 3
For i8 = 1 To 3
For i9 = 1 To 3
Sheets("Rapor").Cells(a, 1) = a - 1
Sheets("Rapor").Cells(a, 2) = i1
Sheets("Rapor").Cells(a, 3) = i2
Sheets("Rapor").Cells(a, 4) = i3
Sheets("Rapor").Cells(a, 5) = i4
Sheets("Rapor").Cells(a, 6) = i5
Sheets("Rapor").Cells(a, 7) = i6
Sheets("Rapor").Cells(a, 8) = i7
Sheets("Rapor").Cells(a, 9) = i8
Sheets("Rapor").Cells(a, 10) = i9
Sheets("Rapor").Cells(a, 11) = i10
For i = 1 To 10
ara_toplam = ara_toplam + WorksheetFunction.VLookup(i, Sheets("Data").Columns("A:D"), Sheets("Rapor").Cells(a, i + 1) + 1, False)
If Sheets("Rapor").Cells(a, i + 1) = 1 Then
worker1 = worker1 + WorksheetFunction.VLookup(i, Sheets("Data").Columns("A:D"), Sheets("Rapor").Cells(a, i + 1) + 1, False)
ElseIf Sheets("Rapor").Cells(a, i + 1) = 2 Then
worker2 = worker2 + WorksheetFunction.VLookup(i, Sheets("Data").Columns("A:D"), Sheets("Rapor").Cells(a, i + 1) + 1, False)
ElseIf Sheets("Rapor").Cells(a, i + 1) = 3 Then
worker3 = worker3 + WorksheetFunction.VLookup(i, Sheets("Data").Columns("A:D"), Sheets("Rapor").Cells(a, i + 1) + 1, False)
End If
Next i
Sheets("Rapor").Cells(a, 12) = ara_toplam
Sheets("Rapor").Cells(a, 13) = worker1
Sheets("Rapor").Cells(a, 14) = worker2
Sheets("Rapor").Cells(a, 15) = worker3
ara_toplam = 0: worker1 = 0: worker2 = 0: worker3 = 0
a = a + 1
Next i10
Next i9
Next i8
Next i7
Next i6
Next i5
Next i4
Next i3
Next i2
Next i1
End Sub
This sounds like a combination problem (order doesn't matter).
Option Explicit
Sub main()
Call for_each_in_others(rDATA:=Worksheets("Sheet1").Range("A2"), bHDR:=True)
End Sub
Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
Dim v As Long, w As Long
Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With rDATA.Parent
With rDATA(1).CurrentRegion
'Debug.Print rDATA(1).Row - .Cells(1).Row
With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
sErrorRng = .Address(0, 0)
vTMPs = .Value2
ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
iMAXROWS = 1
'On Error GoTo bm_Output_Exceeded
For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
vCOLs(w) = Application.CountA(.Columns(w))
iMAXROWS = iMAXROWS * vCOLs(w)
Next w
'control excessive or no rows of output
If iMAXROWS > Rows.Count Then
GoTo bm_Output_Exceeded
ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
GoTo bm_Nothing_To_Do
End If
On Error GoTo bm_Safe_Exit
ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
iINCROWS = 1
For w = LBound(vVALs, 2) To UBound(vVALs, 2)
iINCROWS = iINCROWS * vCOLs(w)
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
Next v
Next w
End With
End With
.Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
If bHDR Then
rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
End If
rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
GoTo bm_Safe_Exit
bm_Nothing_To_Do:
MsgBox "There is not enough data in " & sErrorRng & " to perform expansion." & Chr(10) & _
"This could be due to a single column of values or one or more blank column(s) of values." & _
Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
"Single or No Column of Raw Data"
GoTo bm_Safe_Exit
bm_Output_Exceeded:
MsgBox "The number of expanded values created from " & sErrorRng & _
" (" & Format(iMAXROWS, "\> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
" columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
"Too Many Entries"
bm_Safe_Exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.EnableEvents = bTGGL
Application.ScreenUpdating = bTGGL
End Sub
Before:
After:
Expanding column cells for each column cell
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