複数シート、計算範囲が可変でのピボットテーブルマクロ

初めてのマクロで困っています。

エラーメッセージは、
実行時エラー　'13':
型が一致しません。
＝＝＝で囲んだ部分がデバックをクリックすると黄色で表示されます。
すみませんが、どなたかご指摘お願いします。
どうぞよろしくお願いいたします。

Sub test()
Dim i As Integer
Dim SET_SheetCnt As Integer
Dim SET_SheetName As String
Dim SET_SheetN_C As String
Dim SET_startRow As Long
Dim SET_endRow As Long
Dim SET_startCell As String
Dim SET_endCell As String
Dim SET_Cell As String
Dim SET_Returnsheet As String
Dim DQ As String
Dim SET_FileNo As Integer

SET_SheetCnt = ThisWorkbook.Sheets.Count
SET_Returnsheet = ActiveSheet.Name
SET_FileNo = FreeFile
DQ = Chr$(&H22)

Sheets(SET_Returnsheet).Cells.Clear

For i = 1 To SET_SheetCnt
SET_SheetName = Worksheets(i).Name
If SET_SheetName <> SET_Returnsheet And SET_SheetName <> "template" Then
With ThisWorkbook.Worksheets(i)
'Start行
Cells(2, 2).Select
SET_startRow = .Cells.Find(What:="業務名", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=False).Row
SET_startCell = "R" & SET_startRow & "C3"

'End行
SET_endRow = .Cells(.Rows.Count, 19).End(xlUp).Row
SET_endCell = "R" & SET_endRow & "C19"
SET_Cell = SET_startCell & ":" & SET_endCell

'計算範囲の書き込み
Worksheets(SET_Returnsheet).Cells(1, 1).Value = "計算範囲"
Worksheets(SET_Returnsheet).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = "Array(" & DQ & "'" & SET_SheetName & "'!" & SET_Cell & DQ & ", " & DQ & SET_SheetName & DQ & "), "

End With
End If
Next i

'最終セルの不要な文字列を取りファイルに格納
Sheets(SET_Returnsheet).Select
Dim LastRow As Integer
With Worksheets(SET_Returnsheet).Cells.SpecialCells(xlCellTypeConstants).Areas
With .Item(.Count)
LastRow = .Item(.Count).Row
End With
End With

Dim a As String
Dim b As String
Dim c As String
Dim d As String

a = Worksheets(SET_Returnsheet).Cells(LastRow, 1).Value
b = Len(a)
c = Mid(a, 1, (b - 2))
Worksheets(SET_Returnsheet).Cells(LastRow, 1).Value = c

Open "c:\test.txt" For Output As #SET_FileNo
For i = 2 To LastRow
d = Worksheets(SET_Returnsheet).Cells(i, 1).Value
Print #SET_FileNo, d;
Next i
Close #SET_FileNo

Dim FileData As variant
Open "c:\test.txt" For Input As #SET_FileNo
While Not EOF(SET_FileNo)
Line Input #SET_FileNo, FileData
Debug.Print FileData
Wend
Close #SET_FileNo

'ピボット計算-------
Worksheets(SET_Returnsheet).Activate
Sheets(SET_Returnsheet).Cells.Clear

'==ここから黄色で囲まれる分です====
ThisWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, SourceData:= _
Array(FileData)).CreatePivotTable TableDestination _
:=Range("A11"), TableName:="ピボットテーブル1"
'===ここまで====
ActiveSheet.PivotTables("ピボットテーブル1").SmallGrid = False
ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("データ").PivotItems( _
"データの個数 : 値").Position = 1
Range("A17").Select
ActiveWindow.SmallScroll Down:=-9
ActiveSheet.PivotTables("ピボットテーブル1").PivotSelect "行[すべて]", xlLabelOnly
Range("A11").Select
ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("データの個数 : 値").Function = _
xlSum

End Sub

No.1 ベストアンサー 回答者： pauNed 回答日時： 2007/05/01 13:55

こんにちは。

複数シートからのピボットのSourceDataは、
R1C1形式アドレスの『配列』である事が必要のようです。
文字列をArray()に入れるのではなく、素直に配列に格納したほうが良さそう。

Sub sample()
　　Dim ws　As Worksheet 'For Each...Next WorksheetsLoop用
　　Dim r　 As Range　　 '検索結果セル格納用
　　Dim rs　As Range　　 '各Sheetピボット元データ範囲格納用
　　Dim v　 As Variant　 'アドレス,Sheet名格納用Array
　　Dim x() As Variant　 'Arrayをさらに格納する配列
　　Dim i　 As Long　　　'該当Sheetカウントアップ用（配列サイズ変更）

　　ActiveSheet.UsedRange.Clear
　　For Each ws In Worksheets
　　　　With ws
　　　　　　If Not ws Is ActiveSheet And .Name <> "template" Then
　　　　　　　　Set r = .Cells.Find(What:="業務名", _
　　　　　　　　　　　　　　　　　　After:=.Cells(2, 2), _
　　　　　　　　　　　　　　　　　　LookIn:=xlFormulas, _
　　　　　　　　　　　　　　　　　　LookAt:=xlPart, _
　　　　　　　　　　　　　　　　　　SearchOrder:=xlByRows, _
　　　　　　　　　　　　　　　　　　SearchDirection:=xlNext, _
　　　　　　　　　　　　　　　　　　MatchCase:=False, _
　　　　　　　　　　　　　　　　　　MatchByte:=False)
　　　　　　　　If Not r Is Nothing Then
　　　　　　　　　　Set rs = .Range(.Cells(r.Row, 3), .Cells(Rows.Count, 19).End(xlUp))
　　　　　　　　　　v = VBA.Array(rs.Address(1, 1, xlR1C1, True), .Name)
　　　　　　　　　　ReDim Preserve x(0 To i)
　　　　　　　　　　x(i) = VBA.Array(v(0), v(1))
　　　　　　　　　　i = i + 1
　　　　　　　　　　Set r = Nothing
　　　　　　　　　　Set rs = Nothing
　　　　　　　　End If
　　　　　　End If
　　　　End With
　　Next ws
　　'ピボット計算-------
　　With ThisWorkbook.PivotCaches.Add(SourceType:=xlConsolidation, _
　　　　　　　　　　　　　　　　　　　SourceData:=x) _
　　　　　　　　　　 .CreatePivotTable(TableDestination:=Range("A11"), _
　　　　　　　　　　　　　　　　　　　 TableName:="ピボットテーブル1")
　　　　.DataFields(1).Function = xlSum
　　End With
End Sub

ちなみに検索範囲がC列限定なら、データ範囲を確定させる部分は下記でも。

Set r = .Columns("C").Find(What:="業務名", _
　　　　　　　　　　　　　 After:=.Cells(3), _
　　　　　　　　　　　　　 LookIn:=xlFormulas, _
　　　　　　　　　　　　　 LookAt:=xlPart, _
　　　　　　　　　　　　　 SearchOrder:=xlByRows, _
　　　　　　　　　　　　　 SearchDirection:=xlNext, _
　　　　　　　　　　　　　 MatchCase:=False, _
　　　　　　　　　　　　　 MatchByte:=False)
Set rs = .Range(r, .Cells(Rows.Count, 19).End(xlUp))

この回答へのお礼

pauNedさん
こんばんは。
できました！
ありがとうございました！
データ型としてrangeを指定したり、VBA.Arrayなどは
本には載っていないし、初心者には難しい部分だったようですね。
大変勉強になりました。
教えていただいたソースは全て理解はまだできていませんが
じっくり考えて理解して使えるようになりたいと思います。
自分の書いたソースは回りくどく、美しくありませんでしたが
こんなにすっきりと簡潔にできるのですね。
本当に、どうもありがとうございました。

お礼日時：2007/05/01 22:22