- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 247
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-11-14
              
|
12#
發表於 2013-3-19 10:57
| 只看該作者
本帖最後由 Hsieh 於 2013-3-19 11:01 編輯
回復 11# amychlo
這樣就很難判斷錯誤出在哪裡
加入底下紅字部分看看
如果還不行最好將3檔案上傳測試看看
Sub 彙整()
Dim Ar()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
'fd="D:\" '指定A、B2檔案的存放目錄
fs = Array("A.xls", "B.xls")
d("規格") = "數量"
For Each f In fs
With Workbooks.Open(fd & f)
With .Sheets(1)
i = i + 1
ReDim Preserve Ar(2, s)
Ar(0, s) = "規格": Ar(1, s) = "數量"
s = s + 1
.UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
With ThisWorkbook.Sheets(i)
For Each a In .Range(.[B2], .[B2].End(xlDown))
mystr = Mid(a, 1 / (i / 2))
If IsEmpty(d(mystr)) Then d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) Else d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) - d(mystr)
ReDim Preserve Ar(2, s)
Ar(0, s) = mystr: Ar(1, s) = a.Offset(, IIf(i = 1, 7, 2)).Value
s = s + 1
Next
ThisWorkbook.Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
Erase Ar: s = 0
End With
End With
.Close 0
End With
Next
With Sheets(3)
.[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub |
|
發表於 2013-3-19 10:55
| 
