- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 142
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2026-7-16
                
|
回復 3# ivan731129 - Sub Ex()
- Dim A As Range
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- d1("公司") = Array("公司", "編號", "產量", "地址", "電話") '合併後標題列文字
- With Sheet2
- For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
- d(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value) '將客戶資料儲存
- Next
- End With
- With Sheet1
- For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
- If IsEmpty(d1(A & A.Offset(, 3))) Then '以時間與客戶名稱為索引儲存
- d1(A & A.Offset(, 3)) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 3).Value, d(A.Value)(0), d(A.Value)(1))
- Else
- ar = d1(A & A.Offset(, 3))
- If A.Offset(, 3).Value > ar(2) Then ar(2) = A.Offset(, 3).Value
- d1(A & A.Offset(, 3)) = ar
- End If
- Next
- End With
- Sheet5.[A1].Resize(d1.Count, 5) = Application.Transpose(Application.Transpose(d1.items))
- End Sub
複製代碼 |
|