Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 155|回复: 1

VBA代码优化

[复制链接]
发表于 2019-4-25 07:40 | 显示全部楼层 |阅读模式
1学分
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)重写比检查,可能更方便
发表于 2019-4-25 07:40 | 显示全部楼层
建议
1)上传附件,写好说明
2)重写比检查,可能更方便
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2019-7-18 06:57 , Processed in 0.046800 second(s), 4 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表