amychlo

回復 10# Hsieh
大大：
我的工作表是剛好只有三張工作表，
沒有第四張。

Hsieh

回復 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

amychlo

回復 12# Hsieh
大大：感恩你！
目前測試成功。
就如你所加的一樣，OK了！

Hsieh

回復 13# amychlo
這原因就出現在因為開啟來源檔案後作用視窗變成來源檔案
未指定活頁簿的工作表就會指向該做用中活頁簿
所以當A或B檔案沒有第3張工作表時即會出現此錯誤