麻辣家族討論版版 - Powered by Discuz! Board

Sub Ex()
Dim Sh As Worksheet, R As Range, C As Range, S$, d(1 To 3) As Object, Ar
Set d(1) = CreateObject("scripting.dictionary")
Set d(2) = CreateObject("scripting.dictionary")
Set d(3) = CreateObject("scripting.dictionary")
Ar = Join(Application.Transpose(Application.Transpose(Sheets("1").[A3:F3])), ",")
For Each Sh In Sheets(Array("1", "2", "3", "4"))
With Sh
For Each R In .Range("g3", .Range("iv3").End(xlToLeft)(1, 0))
d(1)(R.Value) = ""
For Each C In .Range(R(2, 1), .Cells(.Range("F" & Rows.Count).End(xlUp).Row - 1, R.Column)).SpecialCells(xlCellTypeConstants)
If C <> "" Then
S = R.Value & Join(Application.Transpose(Application.Transpose(.Cells(C.Row, "A").Cells.Resize(1, 6).Value)), "")
d(2)(S) = C.Value
S = Join(Application.Transpose(Application.Transpose(.Cells(C.Row, "A").Cells.Resize(1, 6).Value)), "")
d(3)(S) = .Cells(C.Row, "A").Cells.Resize(1, 6).Value
End If
Next
Next
End With
Next
With Sheets("要匯整的總表")
.Cells.Clear
Ar = Split(Ar & "," & Join(d(1).keys, ","), ",")
.[A1].Resize(, UBound(Ar) + 1) = Ar
.[A2].Resize(d(3).Count, 6) = Application.Transpose(Application.Transpose(d(3).items))
For Each R In .Range("a1").CurrentRegion.Columns
If R.Column > 6 Then
For Each C In R.Cells
S = R.Cells(1) & Join(Application.Transpose(Application.Transpose(.Cells(C.Row, "A").Cells.Resize(1, 6).Value)), "")
If d(2).Exists(S) Then C = d(2)(S)
Next
End If
Next
.Range("a1").CurrentRegion.Sort KEY1:=.[A1], KEY2:=.[F1], Header:=xlYes
Set R = .Range("a1").CurrentRegion
Set R = .Range("a1").CurrentRegion.Cells(R.Rows.Count, R.Columns.Count)
.Cells(R.Row + 1, "F") = "總計"
.Range(.Cells(R.Row + 1, "G"), R.Offset(1)) = "=SUM(R2C:R[-1]C)"
.Range(.Cells(R.Row + 1, "G"), R.Offset(1)).Value = .Range(.Cells(R.Row + 1, "G"), R.Offset(1)).Value
.Cells(1, R.Column + 1) = "總計"
.Range(.Cells(2, R.Column + 1), R.Offset(, 1)) = "=SUM(RC7:RC[-1])"
.Range(.Cells(2, R.Column + 1), R.Offset(, 1)).Value = .Range(.Cells(2, R.Column + 1), R.Offset(, 1)).Value
End With
End Sub

複製代碼

Sub Ex()
Dim MySh As Worksheets, Sh As Worksheet, MyId As Range, Ar(), Ay(), Ary(), A As Range
Dim s%, n&
Set d = CreateObject("Scripting.Dictionary")
For Each Sh In Sheets(Array("1", "2", "3", "4"))
With Sh
Set MyId = .Cells.Find("品號", lookat:=xlWhole)
For Each A In MyId.EntireRow.SpecialCells(xlCellTypeConstants)
If A <> "總計" And d.exists(A.Value) = False Then d(A.Value) = d.Count
Next
End With
Next
d("總計") = d.Count
With Sheets.Add
On Error Resume Next
Application.DisplayAlerts = False
Sheets("用量需求總表").Delete
.Name = "用量需求總表"
.[A1].Resize(, d.Count) = d.keys
ReDim Ay(0 To d.Count)
For Each Sh In Sheets(Array("1", "2", "3", "4"))
ReDim Ar(d.Count)
With Sh
Set MyId = .Cells.Find("品號", lookat:=xlWhole)
For Each A In MyId.EntireRow.SpecialCells(xlCellTypeConstants)
Ar(s) = d(A.Value)
s = s + 1
Next
For Each A In .Range(MyId, MyId.End(xlDown))
If A <> "總計" Then
For i = 0 To d.Count
If Ar(i) <> "" Then Ay(Ar(i)) = .Cells(A.Row, 1).Offset(, i).Value
Next
ReDim Preserve Ary(n)
Ary(n) = Ay
n = n + 1
End If
ReDim Ay(0 To d.Count)
Next
End With
s = 0
Next
.[A1].Resize(n, d.Count) = Application.Transpose(Application.Transpose(Ary))
.Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 75
End With
Application.DisplayAlerts = True
End Sub

複製代碼