Posts by dangle

Sub SortWS()
Dim i As Long, r As Range
Application.ScreenUpdating = False
With CreateObject("System.Collections.SortedList")
    For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
        .Item(r.Offset(, 1).Value) = r.Value
    Next
    For i = 0 To .Count - 1
        Sheets(.getbyindex(i)).Move after:=Sheets(.Count)
    Next
End With
Application.ScreenUpdating = True
End Sub

Sub SplitCells()
Dim x As Long, z, rCell As Range
For Each rCell In Sheets("Sheet1").Cells(1).CurrentRegion
    If rCell <> "" Then
        For Each z In Split(rCell, vbLf)
            x = x + 1
            rCell.Offset(x + 2) = z
        Next
        x = 0
    End If
Next
End Sub

Sub TRtoCol()
Dim a, b(), i As Long, j As Long, k As Long, x As Long
a = Sheets("Sheet1").Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1) + (UBound(a, 1) * UBound(a, 2)), 1 To UBound(a, 2))
For i = 2 To UBound(a, 1)
    For j = 6 To UBound(a, 2)
        If a(i, j) <> "" Then
            x = x + 1
            For k = 1 To 4
                b(x, k) = a(i, k)
            Next
            b(x, 6) = a(1, j): b(x, 7) = a(i, j)
        End If
    Next
Next
Sheets("Sheet3").Cells(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Sub Filtering()
Dim a, i As Long, j As Long, z
Dim aList As Object
Set aList = CreateObject("System.Collections.ArrayList")
a = Sheets("Sheet1").Cells(1).CurrentRegion.Value
ReDim z(1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a, 1)
        If a(i, 12) < 0 Then .Item(a(i, 3)) = .Count + 1
    Next
    For i = 1 To UBound(a, 1)
        If .exists(a(i, 3)) Then
            For j = 1 To UBound(a, 2)
                z(j) = a(i, j)
            Next
            aList.Add z
        End If
    Next
End With
With Sheets("Sheet2")
    Sheets("Sheet1").Rows(1).Copy .Cells(1)
    .Cells(2, 1).Resize(aList.Count, UBound(a, 2)).Value = Application.Transpose(Application.Transpose(aList.toarray()))
End With
End Sub

Sub AverageReviews()
Dim a, i As Long, tmp, z
Dim ws As Worksheet
a = Sheets("Sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a, 1)
        If a(i, 4) <> "" Then
            tmp = Mid(a(i, 2), 1, InStr(1, a(i, 2), "-") - 1)
            If Not .exists(tmp) Then
                .Item(tmp) = Array(tmp, (a(i, 4) * a(i, 6)) / a(i, 6), a(i, 4) * a(i, 6), a(i, 6))
            Else
                z = .Item(tmp)
                z(2) = z(2) + (a(i, 4) * a(i, 6)): z(3) = z(3) + a(i, 6)
                z(1) = z(2) / z(3)
                .Item(tmp) = z
            End If
        End If
    Next
    Set ws = Worksheets.Add(after:=Sheets(Worksheets.Count))
    ws.Cells(1).Resize(.Count, 2).Value = Application.Transpose(Application.Transpose(.items))
End With
End Sub

Sub F1Fantasy()
Dim a, b(), i As Long, j As Long, k As Long, TeamTotal, DriverTotal, n As Long
Dim TeamList As Object, DriverList As Object
Dim ws As Worksheet
Set TeamList = CreateObject("System.Collections.ArrayList")
Set DriverList = CreateObject("System.Collections.ArrayList")
a = Sheets("Team and Drivers").Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
    For j = i + 1 To UBound(a, 1)
        For k = j + 1 To UBound(a, 1)
            TeamList.Add (Array(a(i, 1), a(j, 1), a(k, 1), a(i, 2) + a(j, 2) + a(k, 2)))
        Next
    Next
Next
a = Sheets("Team and Drivers").Cells(16, 1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
    For j = i + 1 To UBound(a, 1)
        For k = j + 1 To UBound(a, 1)
            DriverList.Add (Array(a(i, 1), a(j, 1), a(k, 1), a(i, 2) + a(j, 2) + a(k, 2)))
        Next
    Next
Next
ReDim b(1 To 200000, 1 To 7)
For i = 0 To TeamList.Count - 1
    TeamTotal = TeamList(i)
    For j = 0 To DriverList.Count - 1
        DriverTotal = DriverList(j)
        If TeamTotal(3) + DriverTotal(3) < 76 Then
            n = n + 1
            For k = 1 To 3
                b(n, k) = DriverTotal(k - 1): b(n, k + 3) = TeamTotal(k - 1)
            Next
            b(n, 7) = DriverTotal(3) + TeamTotal(3)
        End If
    Next
Next
Set ws = Worksheets.Add
ws.Range("a1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Sub Consolidate()
Dim a, i As Long, ws As Worksheet
With CreateObject("Scripting.Dictionary")
    For Each ws In Worksheets
        If ws.Name <> "Result" Then
            With ws
                a = .UsedRange.Value
            End With
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" And a(i, 1) <> "Quote Sheet" And a(i, 1) <> "Materials" Then
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = a(i, 3)
                    Else
                        .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 3)
                    End If
                    
                End If
            Next
        End If
    Next
    Sheets("Result").Cells(1).Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
End With
End Sub