jcchiang

¦^´_ 1# agietron

§Ú¤]¨Ó½m²ß¤@¤U,¸Õ¸Õ¬Ý
Sub ex()
Dim arr As Variant, a As Variant, b As Variant
Dim d As Object, x%, y%, DSC%
Set d = CreateObject("scripting.dictionary")
DSC = InputBox("¿é¤J§é¦©%", "§é¦©", "60")
With Sheets("¤u§@ªí1")
   With .Range(.[a1], [k1].End(4))
      .Borders.LineStyle = xlLineStyleNone
      .UnMerge
      .ClearContents
   End With
   For Each a In .Range(.[O1], .[O1].End(4))
      If Not d.exists(a.Value) Then d(a.Value) = ""
   Next
End With
For x = 1 To Sheets.Count - 1
   With Sheets(x)
      For Each a In .UsedRange
         If d.exists(a.Value) Then
            For Each b In Array(Array("C", "S220"), Array("M", "M520"), Array("N", "N620"), Array("A", "S220²k±µ"), Array("H", "HSS"), Array("K", "HSS-Co"), Array("S", "SKH"))
               If b(0) = Left(a.Value, 1) Then d(a.Value) = b(1): Exit For
            Next
            arr = Array(.[a1] & "--" & .Name & "²Ä" & a.Row & "¦C", Chr(10))
            For y = 1 To .[a2].End(2).Column
               ReDim Preserve arr(0 To UBound(arr) + 1)
               arr(UBound(arr)) = .Cells(2, y) & "*" & .Cells(a.Row, y) & " "
            Next
            d(a.Value) = Array(d(a.Value), Join(arr, ""), "", "", "", "", "", "=Roundup((" & a.Offset(, 1).Value & " * " & DSC / 100 & "), -1)", "", a.Value)
         End If
      Next
   End With
Next
With Sheets("¤u§@ªí1")
   .[b1].Resize(d.Count, 10) = Application.Transpose(Application.Transpose(d.items))
   With .Range([a1], [k1].End(4))
      For x = 1 To .Rows.Count
         .Cells(x, 1) = x
         .Cells(x, 3).Resize(, 5).Merge
         .Cells(x, 10) = "=Sum(I" & x & "*H" & x & ")"
      Next
      .Borders.LineStyle = xlContinuous
   End With
End With
End Sub