Option Explicit
Private Sub QS(ByRef v1, iL As Long, iH As Long)
Dim pvt As String, tmp As String, tL As Long, tH As Long
tL = iL: tH = iH: pvt = v1((iL + iH) \ 2, 1)
While tL <= tH
While v1(tL, 1) < pvt And tL < iH: tL = tL + 1: Wend
While pvt < v1(tH, 1) And tH > iL: tH = tH - 1: Wend
If (tL <= tH) Then
tmp = v1(tL, 1): v1(tL, 1) = v1(tH, 1): v1(tH, 1) = tmp
tmp = v1(tL, 2): v1(tL, 2) = v1(tH, 2): v1(tH, 2) = tmp
tL = tL + 1: tH = tH - 1
End If
Wend
If iL < tH Then QS v1, iL, tH
If tL < iH Then QS v1, tL, iH
End Sub
Public Sub Test3_Layout1()
Const prefixSheetName As String = "MyResults_"
Dim a() As String, b1() As Variant, b2() As Long, b3() As String, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, pColRightTable As Long, maxRow As Long, maxCol As Long, u As Long, rng As Range, sht As Worksheet, strToSearch As String, v1, v2, v3, z1 As New Collection, z2 As New Collection
Debug.Print Format$(Now, "HH:MM:SS")
pColRightTable = Sheets(1).Columns.Count \ 2 + 1
With Sheets("bom")
Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 3)
Set rng = rng.Resize(rng.Rows.Count - 1)
strToSearch = .Range("E2").Value
End With
ReDim a(1 To rng.Rows.Count, 1 To 2)
For j = 1 To 2
v1 = rng.Columns(j).Value
For i = 1 To UBound(v1, 1)
a(i, j) = v1(i, 1)
Next i
Next j
ReDim b1(1 To UBound(a, 1))
ReDim b2(1 To UBound(a, 1))
v1 = rng.Columns(3).Value
For i = 1 To UBound(b2)
b2(i) = v1(i, 1)
Next i
For i = 1 To UBound(a, 1)
On Error Resume Next
z1.Add key:=a(i, 2), Item:=i
On Error GoTo 0
j = z1(a(i, 2))
If Len(b1(j)) = 0 Then b1(j) = i Else b1(j) = b1(j) & "," & i
Next i
u = z1.Count
For i = 1 To UBound(a, 1)
On Error Resume Next
z1.Add key:=a(i, 1), Item:=-i
On Error GoTo 0
j = Abs(z1(a(i, 1)))
Next i
ReDim b3(1 To UBound(a, 1), 1 To 2)
v1 = Sheets("item").Range("A1").CurrentRegion.Value
For i = 2 To UBound(v1, 1)
On Error Resume Next
j = Abs(z1(v1(i, 1)))
If Err.Number = 0 Then b3(j, 1) = v1(i, 2) & "|" & v1(i, 3)
On Error GoTo 0
Next i
v1 = Sheets("order").Range("A1").CurrentRegion.Value
For i = 2 To UBound(v1, 1)
On Error Resume Next
j = Abs(z1(v1(i, 1)))
If Err.Number = 0 Then
If Len(b3(j, 2)) = 0 Then b3(j, 2) = v1(i, 4)
b3(j, 2) = b3(j, 2) & "|" & v1(i, 2) & "|" & v1(i, 3)
End If
On Error GoTo 0
Next i
If Len(strToSearch) Then
On Error Resume Next
i = z1(strToSearch)
If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
On Error GoTo 0
z2.Add key:=strToSearch, Item:=i
Else
i = 0
For Each v1 In z1
i = i + 1
If i > u Then Exit For
z2.Add key:=a(v1, 2), Item:=v1
Next v1
End If
For i = 1 To UBound(b1)
If Len(b1(i)) Then
v1 = Split(b1(i), ",")
ReDim c(1 To UBound(v1) + 1)
For j = 1 To UBound(c)
c(j) = v1(j - 1)
Next j
For j = 1 To UBound(c)
For k = j + 1 To UBound(c)
If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
Next k
Next j
b1(i) = c
On Error Resume Next
For j = 1 To UBound(c)
z2.Remove a(c(j), 1)
Next j
On Error GoTo 0
End If
Next i
ReDim v1(1 To z2.Count, 1 To 2)
i = 0
For Each v2 In z2
i = i + 1
v1(i, 1) = a(v2, 2)
v1(i, 2) = v2
Next v2
Set z2 = Nothing
QS v1, 1, UBound(v1, 1)
For i = 1 To UBound(v1, 1)
z2.Add Array(v1(i, 2), 1)
Next i
Debug.Print Format$(Now, "HH:MM:SS")
Application.ScreenUpdating = False
maxRow = Sheets(1).Rows.Count '10
Application.DisplayAlerts = False
For Each sht In Worksheets
If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
Next sht
Application.DisplayAlerts = True
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = prefixSheetName & "1"
pRow = 1
Do
v1 = z2(1)
z2.Remove 1
pRow = pRow + 1
pCol = v1(1)
If maxCol < pCol Then maxCol = pCol
If pCol = pColRightTable Then MsgBox "Location of second table is not right enough, please change (raise) the value of pColRightTable !": Exit Sub
If pRow > maxRow Then
i = CLng(Split(sht.Name, "_")(1)) + 1
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = prefixSheetName & i
pRow = 1
End If
With sht.Rows(pRow)
If pCol = 1 Then
.Cells(pCol) = a(v1(0), 2)
.Cells(pCol + 1).Resize(, 2) = Split(b3(v1(0), 1), "|")
v3 = Split("" & "|" & b3(v1(0), 2), "|")
.Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
v2 = b1(v1(0))
Else
.Cells(pCol) = a(v1(0), 1)
v2 = Empty
On Error Resume Next
i = z1(a(v1(0), 1))
v2 = b1(i)
On Error GoTo 0
i = Abs(i)
.Cells(pCol + 1).Resize(, 2) = Split(b3(i, 1), "|")
v3 = Split(v1(2) & "|" & b3(i, 2), "|")
.Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
End If
End With
If IsArray(v2) Then
For i = UBound(v2) To 1 Step -1
If z2.Count Then
z2.Add Item:=Array(v2(i), pCol + 1, b2(v2(i))), before:=1
Else
z2.Add Item:=Array(v2(i), pCol + 1, b2(v2(i)))
End If
Next i
End If
Loop Until z2.Count = 0
maxCol = maxCol + 2
Application.DisplayAlerts = False
For Each sht In Worksheets
If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then Range(sht.Columns(maxCol + 2), sht.Columns(pColRightTable - 1)).Delete xlShiftToLeft
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf
End Sub
Public Sub Test3_Layout2()
Const prefixSheetName As String = "MyResults_"
Dim a() As String, b1() As Variant, b2() As Long, b3() As String, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, pColRightTable As Long, maxRow As Long, maxCol As Long, u As Long, rng As Range, sht As Worksheet, strToSearch As String, v1, v2, v3, z1 As New Collection, z2 As New Collection
Debug.Print Format$(Now, "HH:MM:SS")
pColRightTable = Sheets(1).Columns.Count \ 2 + 1
With Sheets("bom")
Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 3)
Set rng = rng.Resize(rng.Rows.Count - 1)
strToSearch = .Range("E2").Value
End With
ReDim a(1 To rng.Rows.Count, 1 To 2)
For j = 1 To 2
v1 = rng.Columns(j).Value
For i = 1 To UBound(v1, 1)
a(i, j) = v1(i, 1)
Next i
Next j
ReDim b1(1 To UBound(a, 1))
ReDim b2(1 To UBound(a, 1))
v1 = rng.Columns(3).Value
For i = 1 To UBound(b2)
b2(i) = v1(i, 1)
Next i
For i = 1 To UBound(a, 1)
On Error Resume Next
z1.Add key:=a(i, 2), Item:=i
On Error GoTo 0
j = z1(a(i, 2))
If Len(b1(j)) = 0 Then b1(j) = i Else b1(j) = b1(j) & "," & i
Next i
u = z1.Count
For i = 1 To UBound(a, 1)
On Error Resume Next
z1.Add key:=a(i, 1), Item:=-i
On Error GoTo 0
j = Abs(z1(a(i, 1)))
Next i
ReDim b3(1 To UBound(a, 1), 1 To 2)
v1 = Sheets("item").Range("A1").CurrentRegion.Value
For i = 2 To UBound(v1, 1)
On Error Resume Next
j = Abs(z1(v1(i, 1)))
If Err.Number = 0 Then b3(j, 1) = v1(i, 2) & "|" & v1(i, 3)
On Error GoTo 0
Next i
v1 = Sheets("order").Range("A1").CurrentRegion.Value
For i = 2 To UBound(v1, 1)
On Error Resume Next
j = Abs(z1(v1(i, 1)))
If Err.Number = 0 Then
If Len(b3(j, 2)) = 0 Then b3(j, 2) = v1(i, 4)
b3(j, 2) = b3(j, 2) & "|" & v1(i, 2) & "|" & v1(i, 3)
End If
On Error GoTo 0
Next i
If Len(strToSearch) Then
On Error Resume Next
i = z1(strToSearch)
If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
On Error GoTo 0
z2.Add key:=strToSearch, Item:=i
Else
i = 0
For Each v1 In z1
i = i + 1
If i > u Then Exit For
z2.Add key:=a(v1, 2), Item:=v1
Next v1
End If
For i = 1 To UBound(b1)
If Len(b1(i)) Then
v1 = Split(b1(i), ",")
ReDim c(1 To UBound(v1) + 1)
For j = 1 To UBound(c)
c(j) = v1(j - 1)
Next j
For j = 1 To UBound(c)
For k = j + 1 To UBound(c)
If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
Next k
Next j
b1(i) = c
On Error Resume Next
For j = 1 To UBound(c)
z2.Remove a(c(j), 1)
Next j
On Error GoTo 0
End If
Next i
ReDim v1(1 To z2.Count, 1 To 2)
i = 0
For Each v2 In z2
i = i + 1
v1(i, 1) = a(v2, 2)
v1(i, 2) = v2
Next v2
Set z2 = Nothing
QS v1, 1, UBound(v1, 1)
For i = 1 To UBound(v1, 1)
z2.Add Array(v1(i, 2), 1, 1)
Next i
Debug.Print Format$(Now, "HH:MM:SS")
Application.ScreenUpdating = False
maxRow = Sheets(1).Rows.Count '10
Application.DisplayAlerts = False
For Each sht In Worksheets
If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
Next sht
Application.DisplayAlerts = True
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = prefixSheetName & "1"
pRow = 1
Do
v1 = z2(1)
z2.Remove 1
pRow = pRow + 1
pCol = v1(1)
If maxCol < pCol Then maxCol = pCol
If pCol = pColRightTable Then MsgBox "Location of second table is not right enough, please change (raise) the value of pColRightTable !": Exit Sub
If pRow > maxRow Then
i = CLng(Split(sht.Name, "_")(1)) + 1
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
sht.Name = prefixSheetName & i
pRow = 1
End If
With sht.Rows(pRow)
If pCol = 1 Then
.Cells(pCol) = v1(2)
v3 = Split("" & "|" & a(v1(0), 2) & "|" & b3(v1(0), 1) & "|" & b3(v1(0), 2), "|")
.Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
v2 = b1(v1(0))
Else
.Cells(pCol) = v1(2)
v2 = Empty
On Error Resume Next
i = z1(a(v1(0), 1))
v2 = b1(i)
On Error GoTo 0
i = Abs(i)
v3 = Split(v1(3) & "|" & a(v1(0), 1) & "|" & b3(i, 1) & "|" & b3(i, 2), "|")
.Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
End If
End With
If IsArray(v2) Then
For i = UBound(v2) To 1 Step -1
If z2.Count Then
z2.Add Item:=Array(v2(i), pCol + 1, i, b2(v2(i))), before:=1
Else
z2.Add Item:=Array(v2(i), pCol + 1, i, b2(v2(i)))
End If
Next i
End If
Loop Until z2.Count = 0
Application.DisplayAlerts = False
For Each sht In Worksheets
If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then Range(sht.Columns(maxCol + 1), sht.Columns(pColRightTable - 1)).Delete xlShiftToLeft
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks