[コピー領域と貼り付け領域の形が違う]エラーが表示されるが?

Question 101.3 Excel VBA Borad (掲示板)より Previous Next
いつもとても役に立つ情報、頼りにさせていただいております。
自分で組んだマクロでエラーが出てしまい考えあぐねております。ご教示いただけましたらうれしいです。

使用するファイル、フォルダーなど====================================
①データブック格納フォルダー
②データブック(複数)
③データシート(5シート(うち1シートはリスト用シートなので、実際参照するのは4シート。定義が複雑になるのも面倒なので、参照してしまっても良いと思っています。)
④抽出用完成ブック
⑤抽出用完成シート
⑥抽出用集約シート  以上のものがあります。

①内の②をオープン、③をフィルタをかけて参照。 ④の⑥に可視セルをコピー。 ⑥から⑤へ必要データをコピー。完成。 という流れでマクロを作成しています。
下記プログラムで③の1シート目をコピー⑥へペースト。 2シート目コピー。 ⑥の最終行取得までは動いているようなのですが、 2シート目からのペースト(★部分)でエラー発生。
Public Function 抽出()
    Application.ScreenUpdating = False
'変数定義====================================
Dim FSO As FileSystemObject, FOL As Folder, F As File
Dim WS As Worksheet, RN As Range
Dim TWB As Workbook, TWS As Worksheet
Dim i As Long
Dim r As Long
'設定エリア=====================================
    Set WS = ThisWorkbook.Sheets("完成")                '最終完成形用のシート
    Set WSS = ThisWorkbook.Sheets("集約")               '一旦貼付用のシート
    Set RN = WS.Cells(6, 1)                             '書出し開始基準セル
    Set FSO = CreateObject("Scripting.FileSystemObject") 'ファイルシステムアクセス
                                                    '参照設定Scripting Runtime)
    Set FOL = FSO.GetFolder("C:\抽出用フォルダー\"'抽出元ファイル格納フォルダー
'======================================================
'抽出用フォルダー内エクセルファイルオープン、フィルタ、可視セルコピー
'======================================================
    For Each F In FOL.Files
        If F.Name Like "*.xls" Then             '「抽出用フォルダーの中のエクセルファイル」
            Set TWB = Workbooks.Open(F, ReadOnly:=True)
            For Each TWS In ActibeWorkbook.Worksheets   'データブックのワークシートを順に参照
                TWS.Activate
                Cells.Select
                With Selection                      '結合解除
                    .MergeCells = False
                End With
                If Not Cells(6, 2) = "" Then       'もし、最初のデータ行にデータがあれば
                    Selection.AutoFilter Field:=1, Criteria1:="="
                                                    'フィールド1が空白セルをフィルタ
                    Selection.Range("B6").SpecialCells(xlCellTypeVisible).Copy
                                                    '可視セルコピ
                    WSS.Activate                    '一旦貼付け用「集約」シートに貼付け
                    r = Range("B65536").End(xlUp).Row + 1
                    Range(Cells(r, 1), Cells(r, 1)).Select
                                                    '2つめのシート以降は最初のデータと
                                                    'かぶらないよう最終セル取得
                    WSS.PasteSpacial               '★貼付け★2つめのデータ貼付けでエラー
                    Application.CutCopyMode = False
                End If
            Next                                    '次のシートへ
            TWB.Close (False)                      '全てのシートを参照したらブックを閉じる
        End If
    Next                                            '次のブックへ
'============================================================================
'↓以降、一旦取りまとめた「集約」シートから「完成形」シートに必要データを貼付けし、
'  全て終わったら集約シートのデータを削除というプログラムが続く。
End Function
実行時エラー 右図のように表示されます。
つたないプログラムで沢山無駄があると思うのですが。。 1シートだけ参照だと問題なく動きます。
selectionの多用もお恥ずかしいのですが、、、 解決策はありますでしょうか。 なお、バージョンは Excel2000です。
Answer   2010.4.27 永井善王
仕組みのご説明はよくわかりますし、コードを見た限りでは異常を感じません。
しかし、コピペのマクロの貼り付けるコードでのエラーですから、難しく考える必要はないかと思います。
Excelは「・・貼付け領域の形が違う・・」と言っているのですから、「集約」シートに問題があるのではないでしょうか。

コピー貼り付けを結合セルがあるシートで行った場合、Excel 2000(SR-1) ではそのようなエラーが表示されることがあります。 たとえば、Sheet2のA1セルとB1セルを結合しておきます。 そして、Sheet1のA1セルに1、B1セルに2、C1セルに3と入力してから、A1:C1セル範囲を選択してコピーします。

次に、Sheet2のA1セルを選択して貼り付けてみてください。 Excel 2000ではエラーになります。 Excel 2002以降ではエラーになりませんが Sheet2のA1セルとB1セルの結合が解除されてしまいます。
貴方の場合、『何故2つめのシートからエラーが出るのか』と思いあぐねているのではなく、エラーが出たときに、「どこかに結合セルがあるはずだ」と信じて、徹底的に探せば解決すると思いますよ。 ガンバ!

 

Excel VBA Macro