I tried to write a Macro, that does the following:
I have a table with many rows and columns, including one column that holds names
like "J63 System" or "J28 System" specifing which part of a machine every part in a row belongs to. Now I filter for one system and look at the parts: I have one empty column and want to number all the parts with the same part-number, everytime beginning from 1 whenever a new partnumber appears.
but the macro doesnt work correctly and I cant figure out why:
Option Explicit
Dim i As Integer, n As Integer, k As Integer
Dim system As String
Dim part0 As String, part1 As String
Sub temato()
n = 887
k = 888
Do
part0 = Cells(n, 2)
part1 = Cells(k, 2)
If Cells(k, 36) = "J64 Tail Rotor" Then
If part1 = part0 Then
Cells(k, 3) = Cells(k - 1, 3).Value + 1
n = n + 1
k = k + 1
Else
Cells(k, 3) = 1
n = n + 1
k = k + 1
End If
Else
k = k + 1
Debug.Print n
Debug.Print k
Do
'n bleibt
part1 = Cells(k, 2)
If Cells(k, 36) = "J64 Tail Rotor" Then
If part1 = part0 Then
Cells(k, 3) = Cells(n, 3).Value + 1
n = k
k = k + 1
Else
Cells(k, 3) = 1
n = k
k = k + 1
End If
Else
k = k + 1
End If
Loop While Cells(k, 36) <> "J64 Tail Rotor"
End If
Loop While k <= 1260
End Sub
`
Add a reference to Microsoft ActiveX Data Objects 6.1 Library then copy this macro:
Dim oConn As ADODB.Connection, rs As ADODB.Recordset, sSheet as String
Dim sWorkbookName as String
sWorkbookName = ThisWorkbook.FullName
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" &
sWorkbookName & """;Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX = 1"""
sSheet="myDataSheet1"
oConn.Open connString
'just an example of SQL, you have to customize it
sSQL = "SELECT [FIELD1], [FIELD2] FROM [" & sSheet & "$] " &
" WHERE [FIELD1] Like ""*yourmatch"" ORDER BY [FIELD1] ASC"
rs.Open sSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
'dump results on a temporary sheet or on the data sheet in an empty column
ThisWorkbook.Worksheets("tmp_sheet").Range("A2").CopyFromRecordset rs
rs.Close
oConn.Close
Set rs = Nothing
Set oConn = Nothing
Once you post the table structure and specify the desired result I shall write the SQL query
Related
I figure there must be a way to drastically shorten this sub procedure. The reason why I even want to is because it's freezing up the application on the elseif userform1.optTerm line because that worksheet it pulls the data from is 6x longer in rows than the optInSeat list.
Sub LoadEmployee_Cmb_HC()
Dim isWS As Worksheet: Set isWS = ThisWorkbook.Worksheets("In Seat")
Dim tWs As Worksheet: Set tWs = ThisWorkbook.Worksheets("Terms")
Dim a, b As Long, c As Variant, i As Long
If UserForm1.optInSeat = True Then
If UserForm1.optEmployeeName = True Then
For i = 2 To isWS.Cells(Rows.Count, 4).End(xlUp).row
x = Application.CountIf(isWS.Range("D" & 4, "D" & i), _
isWS.Cells(i, 4).Value)
If x = 1 Then
UserForm1.cmbEmployee.AddItem isWS.Cells(i, 4) & " - " & isWS.Cells(i, 1)
End If
Next i
For a = 0 To UserForm1.cmbEmployee.ListCount - 1
For b = 0 To UserForm1.cmbEmployee.ListCount - 1
If UserForm1.cmbEmployee.List(b) > UserForm1.cmbEmployee.List(a) Then
c = UserForm1.cmbEmployee.List(a)
UserForm1.cmbEmployee.List(a) = UserForm1.cmbEmployee.List(b)
UserForm1.cmbEmployee.List(b) = c
End If
Next
Next
ElseIf UserForm1.optEmployeeID = True Then
For i = 2 To isWS.Cells(Rows.Count, 1).End(xlUp).row
x = Application.CountIf(isWS.Range("A" & 1, "A" & i), _
isWS.Cells(i, 1).Value)
If x = 1 Then
UserForm1.cmbEmployee.AddItem isWS.Cells(i, 1) & " - " & isWS.Cells(i, 4)
End If
Next i
For a = 0 To UserForm1.cmbEmployee.ListCount - 1
For b = 0 To UserForm1.cmbEmployee.ListCount - 1
If UserForm1.cmbEmployee.List(b) > UserForm1.cmbEmployee.List(a) Then
c = UserForm1.cmbEmployee.List(a)
UserForm1.cmbEmployee.List(a) = UserForm1.cmbEmployee.List(b)
UserForm1.cmbEmployee.List(b) = c
End If
Next
Next
End If
ElseIf UserForm1.optTerm = True Then
If UserForm1.optEmployeeName = True Then
For i = 2 To tWs.Cells(Rows.Count, 4).End(xlUp).row
x = Application.CountIf(tWs.Range("D" & 4, "D" & i), _
tWs.Cells(i, 4).Value)
If x = 1 Then
UserForm1.cmbEmployee.AddItem tWs.Cells(i, 4) & " - " & tWs.Cells(i, 1)
End If
Next i
For a = 0 To UserForm1.cmbEmployee.ListCount - 1
For b = 0 To UserForm1.cmbEmployee.ListCount - 1
If UserForm1.cmbEmployee.List(b) > UserForm1.cmbEmployee.List(a) Then
c = UserForm1.cmbEmployee.List(a)
UserForm1.cmbEmployee.List(a) = UserForm1.cmbEmployee.List(b)
UserForm1.cmbEmployee.List(b) = c
End If
Next
Next
ElseIf UserForm1.optEmployeeID = True Then
For i = 2 To tWs.Cells(Rows.Count, 1).End(xlUp).row
x = Application.CountIf(tWs.Range("A" & 1, "A" & i), _
tWs.Cells(i, 1).Value)
If x = 1 Then
UserForm1.cmbEmployee.AddItem tWs.Cells(i, 1) & " - " & tWs.Cells(i, 4)
End If
Next i
For a = 0 To UserForm1.cmbEmployee.ListCount - 1
For b = 0 To UserForm1.cmbEmployee.ListCount - 1
If UserForm1.cmbEmployee.List(b) > UserForm1.cmbEmployee.List(a) Then
c = UserForm1.cmbEmployee.List(a)
UserForm1.cmbEmployee.List(a) = UserForm1.cmbEmployee.List(b)
UserForm1.cmbEmployee.List(b) = c
End If
Next
Next
End If
End If
End Sub
Instead of trying to shape the data using code, I would suggest creating an SQL statement based on runtime logic, opening a recordset with that data, and pushing the result back into the combobox.
Add a reference (Tools -> References...) to Microsoft ActiveX Data Objects; the latest version, usually 6.1.
(Credit goes to CDP1802's answer, which is the basis for much of the logic here.)
Dim source As String
If optInSeat = True Then
source = "'In Seat$'"
ElseIf optTerm = True Then
source = "Terms$"
End If
If Len(source) = 0 Then Exit Sub ' Do nothing
' sort by columns
Dim orderBy As String, expr As String
If optEmployeeName Then
expr = "Trim(F1) & ' - ' & Trim(F4)"
orderBy = "F1, F4"
ElseIf optEmployeeID Then
expr = "Trim(F4) & ' - ' & Trim(F1)"
orderBy = "F4, F1"
Else
expr = "Trim(F1) & ' - ' & Trim(F4)"
End If
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & ThisWorkbook.FullName & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim sql As String
sql = _
"SELECT " & expr & " " & _
"FROM [" & source & "]"
If Len(orderBy) > 0 Then sql = sql & " ORDER BY " & orderBy
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
' The 2D array comes back in the wrong direction to be set directly.
' We use WorksheetFunctions.Transpose to switch the direction.
cmbEmployees.List = WorksheetFunction.Transpose(rs.GetRows)
Select unique items using a Dictionary Object and sort them in an array. This sorts in ascending order.
Sub LoadEmployee_Cmb_HC()
Dim wb As Workbook, ws As Worksheet
Dim dict, k As String, i As Long
Dim order(2) As Integer
Set wb = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
' data source
If UserForm1.optInSeat = True Then
Set ws = wb.Sheets("In Seat")
ElseIf UserForm1.optTerm = True Then
Set ws = wb.Sheets("Terms")
End If
' sort by columns
If UserForm1.optEmployeeName = True Then
order(1) = 4: order(2) = 1
ElseIf UserForm1.optEmployeeID = True Then
order(1) = 1: order(2) = 4
End If
If order(1) = 0 Or ws Is Nothing Then
' do nothing
Else
' get unique values start in row 4
For i = 4 To ws.Cells(Rows.Count, order(1)).End(xlUp).Row
k = Trim(ws.Cells(i, order(1)).Value)
If Len(k) > 0 And Not dict.exists(k) Then
dict.Add k, k & " - " & Trim(ws.Cells(i, order(2)))
End If
Next
' sort and populate combo
Call SortCombo(dict, UserForm1.ComboBox1)
End If
End Sub
Sub SortCombo(ByRef dict, cmb As ComboBox)
Dim ar, a As Long, b As Long, i As Long, tmp As String
ar = dict.keys
i = UBound(ar)
For a = 0 To i
For b = a To i
If ar(b) < ar(a) Then
tmp = ar(a)
ar(a) = ar(b)
ar(b) = tmp
End If
Next
ar(a) = dict.Item(ar(a)) ' replace with value after it sort
Next
cmb.List = ar
End Sub
Alternative sort using temporary sheet
Sub SortCombo2(ByRef dict, cmb As ComboBox)
Dim wsTmp As Worksheet, rng As Range, k, ar() As String, i As Long
Set wsTmp = ThisWorkbook.Sheets(3)
wsTmp.Cells.Clear
ReDim ar(dict.Count - 1, 0)
i = 0
For Each k In dict.keys
ar(i, 0) = dict(k)
i = i + 1
Next
Set rng = wsTmp.Range("A1:A" & dict.Count)
rng = ar
With wsTmp.Sort
.SetRange rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
cmb.List = rng.Value2
wsTmp.Cells.Clear
End Sub
Test data generator
Sub data()
Dim ws As Worksheet, i, s, n
Set ws = Sheets("Terms")
ws.Cells.Clear
For i = 4 To 35000
s = ""
For n = 1 To 25
s = s & Chr(65 + Int(Rnd() * 26))
Next
ws.Cells(i, 1) = s
ws.Cells(i, 4) = "D" & i
Next
MsgBox "done " & i - 1
End Sub
I've been editing an excel macro that prints a SQL query (which basically shows every item ordered in a delivery order).
So the problem is I noticed that the recordset misses the last two rows from every query I send.
For example: if I send a query with 24 items only shows 22.
If I try the same query in the DDBB it works perfectly fine.
I changed the printing to the worksheet to a listbox (just to try because I noticed the row range was the one needed) and in the listbox it adds 2 rows BUT it doesn't show the results as I show in the image below.
The code is the following (I can't show the query but as I said it works fine in the database):
Set remoteCon = CreateObject("ADODB.Connection")
remoteCon.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver}" _
& ";SERVER=" & "" _
& ";DATABASE=" & "" _
& ";UID=" & "" _
& ";PWD=" & "" _
& ";PORT = "
remoteCon.Execute ("USE db;")
Set rs = CreateObject("ADODB.Recordset")
Sql = 'here goes the query
Set rs = remoteCon.Execute(Sql)
If Not rs.BOF And Not rs.EOF Then
myArray = rs.GetRows
filas = UBound(myArray, 2) 'filas
UserForm1.ListBox3.ColumnCount = 2
UserForm1.ListBox3.ColumnWidths = "50,50"
For j = 0 To filas
UserForm1.ListBox3.AddItem
UserForm1.ListBox3.List(j, 0) = myArray(0, j)
UserForm1.ListBox3.List(j, 1) = myArray(1, j)
Next j
End If
Loop is not necessary. You can use list.column.
If Not rs.BOF And Not rs.EOF Then
myArray = rs.GetRows
filas = UBound(myArray, 2) 'filas
UserForm1.ListBox3.ColumnCount = 2
UserForm1.ListBox3.ColumnWidths = "50,50"
UserForm1.ListBox3.Column = myArray
' For j = 0 To filas
' UserForm1.ListBox3.AddItem
' UserForm1.ListBox3.List(j, 0) = myArray(0, j)
' UserForm1.ListBox3.List(j, 1) = myArray(1, j)
' Next j
End If
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 have a vba module in Excel that had worked a few years ago but not now. I think something has changed (or someone made a change) but I am not sure what. The module is intended to compare the data in Column B (pre-sorted); for each single row or multiple row that matches it outputs a txt file. The first file whether a single row or multiple row is being created but then it stops. It does not go to the next row or group of rows and create a second file (.etc).
The code:
Sub OrderEC()
Dim Header(1 To 50) As Variant
Dim StartRow As Integer
Dim EndRow As Integer
Dim txt As String
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Count() As Variant
Dim x As Integer
Dim i As Integer
Dim Users As Integer
For i = 1 To 50
Header(i) = Cells(1, i)
Next
Set Rng1 = Range("B2:B10000")
For Each cell In Rng1
If cell.Value = "" Then GoTo First
ReDim Preserve Count(0 To 1, 0 To x) As Variant
For i = 0 To x - 1
If cell.Value = Count(1, i) Then
Count(0, i) = Count(0, i) + 1
GoTo First
End If
Next i
Count(1, x) = cell.Value
Count(0, x) = 1
x = x + 1
First:
Next
Users = UBound(Count, 2)
EndRow = 1
For s = 1 To Users
StartRow = EndRow
EndRow = StartRow + Count(0, s - 1)
DataFile = "C:\ECorder\" & "BULK_" & Cells(StartRow + 1, 2).Value & "_" & Format(DateTime.Now, "DDMMYYHHMMSS") & ".bulk"
Open DataFile For Output As #1
For U = 1 To 30
Print #1, Header(U) & "=" & Cells(StartRow + 1, U)
Next U
For v = 31 To 40
txt = Header(v) & "="
For i = 1 To Count(0, s - 1)
If i = 1 Then
txt = txt & Cells(StartRow + i, v)
Else
txt = txt & ", " & Cells(StartRow + i, v)
End If
Next i
Print #1, txt
Next v
For w = 41 To 44
Print #1, Header(w) & "=" & Cells(StartRow + 1, w)
Next w
Close #1
Next s
End Sub
I have a data in excel in the format:
Description Name Percent
Always A 52
Sometimes A 23
Usually A 25
Always B 60
Sometimes B 30
Usually B 15
Always C 75
Sometimes C 11
Usually C 14
I want to sort this data:
For each name the sequence of description has to be same (eg: always followed by sometimes followed by usually) but for three names A, B and C, I want to sort the always percent from smallest to largest. Eg: I want the above example to look like this after sorting:
Description Name Percent
Always C 75
Sometimes C 11
Usually C 14
Always B 60
Sometimes B 30
Usually B 15
Always A 52
Sometimes A 23
Usually A 25
The always percent of name C was highest and always percent of name A was lowest. I hope I was able to explain it. I would really appreciate your help regarding the same.
Here's a vba routine to perform this sort:
Select the data on the sheet and run SortList
Important: this code assumes that the Always, Sometimes, Usually data is grouped by Name (as in your sample data)
Method:
Sub SortList()
Dim dat As Variant
Dim rng As Range
Dim newDat() As Variant
Dim always() As Long
Dim i As Long
Set rng = Selection
If rng.Columns.Count <> 3 Then
MsgBox "Select a range with 3 columns", vbCritical + vbOKOnly
Exit Sub
End If
If StrComp(rng.Cells(1, 1), "Description", vbTextCompare) = 0 Then
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 3)
End If
dat = rng
ReDim always(1 To UBound(dat, 1) / 3)
For i = 1 To UBound(dat)
If StrComp(dat(i, 1), "Always", vbTextCompare) = 0 Then
always(i \ 3 + 1) = i
End If
Next
QuickSort dat, always, LBound(always, 1), UBound(always, 1)
ReDim newDat(1 To UBound(dat, 1), 1 To 3)
For i = 1 To UBound(always)
newDat((i - 1) * 3 + 1, 1) = dat(always(i), 1)
newDat((i - 1) * 3 + 1, 2) = dat(always(i), 2)
newDat((i - 1) * 3 + 1, 3) = dat(always(i), 3)
' Assumes original data is sorted in name order
newDat((i - 1) * 3 + 2, 1) = dat(always(i) + 1, 1)
newDat((i - 1) * 3 + 2, 2) = dat(always(i) + 1, 2)
newDat((i - 1) * 3 + 2, 3) = dat(always(i) + 1, 3)
newDat((i - 1) * 3 + 3, 1) = dat(always(i) + 2, 1)
newDat((i - 1) * 3 + 3, 2) = dat(always(i) + 2, 2)
newDat((i - 1) * 3 + 3, 3) = dat(always(i) + 2, 3)
Next
rng = newDat
End Sub
Private Sub QuickSort(ByRef dat As Variant, ByRef Field() As Long, ByVal LB As Long, ByVal UB As Long)
Dim P1 As Long, P2 As Long, Ref As Variant, TEMP As Long
P1 = LB
P2 = UB
Ref = dat(Field((P1 + P2) / 2), 3)
Do
Do While dat(Field(P1), 3) > Ref
P1 = P1 + 1
Loop
Do While dat(Field(P2), 3) < Ref
P2 = P2 - 1
Loop
If P1 <= P2 Then
TEMP = Field(P1)
Field(P1) = Field(P2)
Field(P2) = TEMP
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If LB < P2 Then Call QuickSort(dat, Field, LB, P2)
If P1 < UB Then Call QuickSort(dat, Field, P1, UB)
End Sub
The Quicksort is adapted from this answer by Konrad Rudolph
It might be easier with ADO:
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer
strFile = "C:\Docs\Book2.xlsm"
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''Comment out the connection string, as appropriate.
''This is the Jet 4 connection string, for < 2007:
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''ACE, for 2007 -
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT s1.[Description], s1.[Name], s1.[Percent] " _
& "FROM [Sheet3$] s1 " _
& "INNER JOIN (SELECT s.Name, s.Percent " _
& "FROM [Sheet3$] s " _
& "WHERE s.Description='Always') As s2 " _
& "ON s1.Name = s2.Name " _
& "ORDER BY s2.Percent DESC, s1.Description"
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet or location for the results
With Worksheets("Sheet4")
For i = 1 To rs.Fields.Count
.Cells(1, i) = rs.Fields(i - 1).Name
Next
.Cells(2, 1).CopyFromRecordset rs
End With
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Sort by Description. Add this formula to column D =RANK(VLOOKUP(INDIRECT("B"&ROW()),B:C, 2, FALSE),C:C ) and sort column D with Smallest to Largest.