VBA代码优化

gqx3563610

Attribute VB_Name = "Module1"



Sub 數據分析()
Dim w As Worksheet, s As Worksheet
Set w = Worksheets("scrap raw data")
Set s = Worksheets("Sheet1")
j = 2
r = w.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To r
If w.Cells(i, 21) <> "" Then
If w.Cells(i, 12) = "S211" Or w.Cells(i, 12) = "S905" Then
D = w.Range("a" & i & ":" & "al" & i)
s.Range("A" & j & ":" & "AL" & j) = D
j = j + 1
End If
End If
Next i
s.Columns("A:k").Delete Shift:=xlShiftToLeft
s.Columns("c:i").Delete Shift:=xlShiftToLeft

i = 2
Do While s.Cells(i, 1) <> ""
If s.Cells(i, 3) <> "" Then
r = s.Cells(i, Columns.Count).End(xlToLeft).Column
s.Cells(i, 4) = s.Cells(i, r)
s.Cells(i, 3) = s.Cells(i, r - 1)
End If

i = i + 1
Loop
s.Columns("e:t").Delete Shift:=xlShiftToLeft

i = 2
Do While Cells(i, 3) <> ""
If Mid(Cells(i, 3), 1, 1) = "B" Then
Cells(i, 3) = "BURN IN"
End If
i = i + 1
Loop

i = 2
Do While Cells(i, 3) <> ""
If Cells(i, 3) = "QTO" Or Cells(i, 3) = QT0 Then
Cells(i, 3) = "QT0"
End If
i = i + 1
Loop
i = 2
Do While Cells(i, 3) <> ""
If Mid(Cells(i, 3), 1, 2) = "S-" Then
Cells(i, 3) = "S_COND"
End If
i = i + 1
Loop
i = 2
Do While Cells(i, 3) <> ""
If Left(Cells(i, 3), 3) = "0T1" Then
Cells(i, 3) = "QT1"
End If
i = i + 1
Loop
S905
S211

End Sub




Sub S211()
Dim w As Worksheet, s As Worksheet
Set w = Worksheets("Sheet1")
Set s = Worksheets("S211")
j = 2
r = w.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
If w.Cells(i, 1) <> "" Then
If w.Cells(i, 1) = "S211" Then
D = w.Range("a" & i & ":" & "al" & i)
s.Range("A" & j & ":" & "AL" & j) = D
j = j + 1
End If
End If
Next i
s.Cells(1, 1) = "Scrap代碼"
s.Cells(1, 2) = "Scrap原因"
s.Cells(1, 3) = "站位"
s.Cells(1, 4) = "料件"
s.Activate
Range("c2").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("c2"), Order:=xlAscending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("A1:d3790")
                        .Apply
    End With

i = 1
r = 2

Do While Cells(i, 3) <> ""
If Cells(i, 3) <> Cells(i - 1, 3) Then
Cells(r, 5) = Cells(i, 3)
Cells(r, 6) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(r, 5))
r = r + 1
End If
i = i + 1
Loop
  Range("f2").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("f2"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("e1:f2599")
        .Apply
    End With
   
    Cells(1, 7) = Cells(1, 5)
Cells(2, 7) = Cells(1, 6)
Cells(1, 9) = Cells(2, 5)
Cells(2, 9) = Cells(2, 6)
Cells(1, 11) = Cells(3, 5)
Cells(2, 11) = Cells(3, 6)
Cells(1, 13) = Cells(4, 5)
Cells(2, 13) = Cells(4, 6)
Range("e:f") = ""

Range("b1").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("b1"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("b1:d2599")
        .Apply
    End With
i = 2
r = 4
Do While Cells(i, 3) <> ""
If Cells(i, 2) <> Cells(i - 1, 2) Then
Cells(r, 6) = Cells(i, 2)
Cells(r, 7) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(r, 6))

Cells(r, 8) = Cells(r, 6)
Cells(r, 9) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("b:b"), Cells(r, 6))

Cells(r, 10) = Cells(r, 6)

Cells(r, 11) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("b:b"), Cells(r, 6))

Cells(r, 12) = Cells(r, 6)

Cells(r, 13) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 13), Range("b:b"), Cells(r, 6))
r = r + 1
End If
i = i + 1
Loop


Range("g4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("g4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("f4:g2599")
        .Apply
    End With

Range("i4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("i4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("h4:i2599")
        .Apply
    End With



Range("k4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("k4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("j4:k2599")
        .Apply
    End With


Range("m4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("m4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("l4:m2599")
        .Apply
    End With


Range("d1").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("d1"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("a1:d2599")
        .Apply
    End With
   

    i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(4, 6), Range("d:d"), Cells(r, 15))


Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(10, 6) = Cells(4, 6)
Cells(10, 6).Interior.Color = 5287936
Cells(10, 7) = Cells(4, 7)
Cells(11, 6) = Cells(10, 15)
Cells(11, 7) = Cells(10, 16)
Cells(12, 6) = Cells(11, 15)
Cells(12, 7) = Cells(11, 16)
Cells(13, 6) = Cells(12, 15)
Cells(13, 7) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("o:p") = ""
'S211 站位TOP1原因TOP1 料件TOP
    i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(5, 6), Range("d:d"), Cells(r, 15))


Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(14, 6) = Cells(5, 6)
Cells(14, 7) = Cells(5, 7)
Cells(14, 6).Interior.Color = 5287936
Cells(15, 6) = Cells(10, 15)
Cells(15, 7) = Cells(10, 16)
Cells(16, 6) = Cells(11, 15)
Cells(16, 7) = Cells(11, 16)
Cells(17, 6) = Cells(12, 15)
Cells(17, 7) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("o:p") = ""

'S211 站位TOP1原因TOP2 料件TOP3

   i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(5, 6), Range("d:d"), Cells(r, 15))


Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(14, 6) = Cells(5, 6)
Cells(14, 7) = Cells(5, 7)
Cells(15, 6) = Cells(10, 15)
Cells(15, 7) = Cells(10, 16)
Cells(16, 6) = Cells(11, 15)
Cells(16, 7) = Cells(11, 16)
Cells(17, 6) = Cells(12, 15)
Cells(17, 7) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("o:p") = ""

'S211 站位TOP1原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(6, 6), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(18, 6) = Cells(6, 6)
Cells(18, 7) = Cells(6, 7)
Cells(18, 6).Interior.Color = 5287936
Cells(19, 6) = Cells(10, 15)
Cells(19, 7) = Cells(10, 16)
Cells(20, 6) = Cells(11, 15)
Cells(20, 7) = Cells(11, 16)
Cells(21, 6) = Cells(12, 15)
Cells(21, 7) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
'添加
'S211 站位TOP1原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("b:b"), Cells(7, 6), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(22, 6) = Cells(7, 6)
Cells(22, 7) = Cells(7, 7)
Cells(22, 6).Interior.Color = 5287936
Cells(23, 6) = Cells(10, 15)
Cells(23, 7) = Cells(10, 16)
Cells(24, 6) = Cells(11, 15)
Cells(24, 7) = Cells(11, 16)
Cells(25, 6) = Cells(12, 15)
Cells(25, 7) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""




'S211 站位TOP2 原因TOP1 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("b:b"), Cells(4, 8), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(10, 8) = Cells(4, 8)
Cells(10, 9) = Cells(4, 9)
Cells(10, 8).Interior.Color = 5287936
Cells(11, 8) = Cells(10, 15)
Cells(11, 9) = Cells(10, 16)
Cells(12, 8) = Cells(11, 15)
Cells(12, 9) = Cells(11, 16)
Cells(13, 8) = Cells(12, 15)
Cells(13, 9) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
   
  
'S211 站位TOP2 原因TOP2 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("b:b"), Cells(5, 8), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(14, 8) = Cells(5, 8)
Cells(14, 9) = Cells(5, 9)
Cells(14, 8).Interior.Color = 5287936

Cells(15, 8) = Cells(10, 15)
Cells(15, 9) = Cells(10, 16)
Cells(16, 8) = Cells(11, 15)
Cells(16, 9) = Cells(11, 16)
Cells(17, 8) = Cells(12, 15)
Cells(17, 9) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
   
   
'S211 站位TOP2 原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("b:b"), Cells(6, 8), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(18, 8) = Cells(6, 8)
Cells(18, 9) = Cells(6, 9)
Cells(18, 8).Interior.Color = 5287936

Cells(19, 8) = Cells(10, 15)
Cells(19, 9) = Cells(10, 16)
Cells(20, 8) = Cells(11, 15)
Cells(20, 9) = Cells(11, 16)
Cells(21, 8) = Cells(12, 15)
Cells(21, 9) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
''''''
'添加
'S211 站位TOP2 原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("b:b"), Cells(7, 8), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(22, 8) = Cells(7, 8)
Cells(22, 9) = Cells(7, 9)
Cells(22, 8).Interior.Color = 5287936

Cells(23, 8) = Cells(10, 15)
Cells(23, 9) = Cells(10, 16)
Cells(24, 8) = Cells(11, 15)
Cells(24, 9) = Cells(11, 16)
Cells(25, 8) = Cells(12, 15)
Cells(25, 9) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""




'S211 站位TOP3 原因TOP1 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("b:b"), Cells(4, 10), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(10, 10) = Cells(4, 10)
Cells(10, 11) = Cells(4, 11)
Cells(10, 10).Interior.Color = 5287936

Cells(11, 10) = Cells(10, 15)
Cells(11, 11) = Cells(10, 16)
Cells(12, 10) = Cells(11, 15)
Cells(12, 11) = Cells(11, 16)
Cells(13, 10) = Cells(12, 15)
Cells(13, 11) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
   
  
'S211 站位TOP2 原因TOP2 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("b:b"), Cells(5, 10), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(14, 10) = Cells(5, 10)
Cells(14, 11) = Cells(5, 11)
Cells(14, 10).Interior.Color = 5287936

Cells(15, 10) = Cells(10, 15)
Cells(15, 11) = Cells(10, 16)
Cells(16, 10) = Cells(11, 15)
Cells(16, 11) = Cells(11, 16)
Cells(17, 10) = Cells(12, 15)
Cells(17, 11) = Cells(12, 16)
r = r + 1
End If
i = i + 1
Loop
Range("O:P") = ""
   
   
'S211 站位TOP2 原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("b:b"), Cells(6, 10), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(18, 10) = Cells(6, 10)
Cells(18, 11) = Cells(6, 11)
Cells(18, 10).Interior.Color = 5287936

Cells(19, 10) = Cells(10, 15)
Cells(19, 11) = Cells(10, 16)
Cells(20, 10) = Cells(11, 15)
Cells(20, 11) = Cells(11, 16)
Cells(21, 10) = Cells(12, 15)
Cells(21, 11) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop

'添加
'S211 站位TOP3 原因TOP3 料件TOP3
i = 1
r = 10

Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 15) = Cells(i, 4)
Cells(r, 16) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("b:b"), Cells(7, 10), Range("d:d"), Cells(r, 15))

Range("P10").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("P10"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("O10:P2599")
        .Apply
    End With
Cells(22, 10) = Cells(7, 10)
Cells(22, 11) = Cells(7, 11)
Cells(22, 10).Interior.Color = 5287936

Cells(23, 10) = Cells(10, 15)
Cells(23, 11) = Cells(10, 16)
Cells(24, 10) = Cells(11, 15)
Cells(24, 11) = Cells(11, 16)
Cells(25, 10) = Cells(12, 15)
Cells(25, 11) = Cells(12, 16)

r = r + 1
End If
i = i + 1
Loop


Cells(3, 14) = Cells(1, 7)
Cells(3, 15) = Cells(2, 7)
Cells(4, 14) = Cells(1, 9)
Cells(4, 15) = Cells(2, 9)
Cells(5, 14) = Cells(1, 11)
Cells(5, 15) = Cells(2, 11)



End Sub

Sub S905()
Dim w As Worksheet, s As Worksheet, q As Worksheet
Set w = Worksheets("Sheet1")
Set s = Worksheets("S905")
Set q = Worksheets("scrap raw data")
j = 2
r = w.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To r
If w.Cells(i, 1) <> "" Then
If w.Cells(i, 1) = "S905" Then
D = w.Range("a" & i & ":" & "al" & i)
s.Range("A" & j & ":" & "AL" & j) = D
j = j + 1
End If
End If
Next i
s.Cells(1, 1) = "Scrap代碼"
s.Cells(1, 2) = "Scrap原因"
s.Cells(1, 3) = "站位"
s.Cells(1, 4) = "料件"
s.Activate
Range("c2").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("c2"), Order:=xlAscending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("A1:d3790")
                        .Apply
    End With

i = 1
r = 2

Do While Cells(i, 3) <> ""
If Cells(i, 3) <> Cells(i - 1, 3) Then
Cells(r, 5) = Cells(i, 3)
Cells(r, 6) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(r, 5))
r = r + 1
End If
i = i + 1
Loop
  Range("f2").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("f2"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("e1:f2599")
        .Apply
    End With
   
    Cells(1, 7) = Cells(1, 5)
Cells(2, 7) = Cells(1, 6)

Cells(1, 9) = Cells(2, 5)
Cells(2, 9) = Cells(2, 6)
Cells(1, 11) = Cells(3, 5)
Cells(2, 11) = Cells(3, 6)
Cells(1, 13) = Cells(4, 5)
Cells(2, 13) = Cells(4, 6)
Range("e:f") = ""


Range("d1").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("d1"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("a1:d2599")
        .Apply
    End With
i = 2
r = 4
Do While Cells(i, 3) <> ""
If Cells(i, 4) <> Cells(i - 1, 4) Then
Cells(r, 6) = Cells(i, 4)
Cells(r, 7) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 7), Range("d:d"), Cells(r, 6))

Cells(r, 8) = Cells(r, 6)
Cells(r, 9) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 9), Range("d:d"), Cells(r, 6))

Cells(r, 10) = Cells(r, 6)

Cells(r, 11) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 11), Range("d:d"), Cells(r, 6))

Cells(r, 12) = Cells(r, 6)

Cells(r, 13) = Application.WorksheetFunction.CountIfs(Range("c:c"), Cells(1, 13), Range("d:d"), Cells(r, 6))
r = r + 1
End If
i = i + 1
Loop


Range("g4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("g4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("f4:g2599")
        .Apply
    End With

Range("i4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("i4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("h4:i2599")
        .Apply
    End With



Range("k4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("k4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("j4:k2599")
        .Apply
    End With


Range("m4").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("m4"), Order:=xlDescending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange Rng:=Range("l4:m2599")
        .Apply
    End With

Cells(3, 14) = Cells(1, 7)
Cells(3, 15) = Cells(2, 7)
Cells(4, 14) = Cells(1, 9)
Cells(4, 15) = Cells(2, 9)
Cells(5, 14) = Cells(1, 11)
Cells(5, 15) = Cells(2, 11)


End Sub

爱疯

建议
1）上传附件，写好说明
2）重写比检查，可能更方便