ExcelVBAでの転記処理エラーについて

ExcelVBAを使用して、データを転記集約させる作業をしたいと思っています。
詳しく言いますと、同一のフォルダ内に各店からの注文書のファイルを保存し（フォーマットは同じ）、それを集計用のファイルで、それぞれ入力してあるデータを読み込み一覧にしていくという作業です。
転記部分をサブルーチンにしています。
実行すると、最後の
topRng.PasteSpecial xlPasteValues
でエラーになり、「実行時エラー1004 この操作には同じサイズの結合セルが
必要です」とメッセージが出ます。
そこで結合セルを解除したのですが、同じメッセージが出てしまいます。
どこをどう修正すればよいのか、お教え頂けないでしょうか？
転記先のセルの開始位置の取得が間違っているのでしょうか？
宜しくお願いいたします。

Dim keyRng As Range

Sub 集計開始()

myDir = "D:\集計用"

flg = 0

ChDir myDir

MyName = Dir(myDir & "\*.xls")

Do While MyName <> ""
Set mybook = Workbooks.Open(MyName)

Call 転記(mybook.Sheets(1).Range("D6"), flg)

flg = 1

Application.DisplayAlerts = False
mybook.Close
Application.DisplayAlerts = True
MyName = Dir
Loop
Application.ScreenUpdating = True

MsgBox ("集計処理が終わりました")

End If

End Sub

Sub 転記(myRng, mytitle)

Set keyRng = Range("A1")

If keyRng = "" And keyRng.Offset(1) = "" Then
Set topRng = keyRng
Else
Set topRng = keyRng.End(xlDown).Offset(1)
End If

Set mytbl = myRng.CurrentRegion

If mytitle = 1 Then
Set mytbl = mytbl.Offset(1, 0).Resize(mytbl.Rows.Count - 1, mytbl.Columns.Count)
End If

mytbl.Copy
topRng.PasteSpecial xlPasteValues

End Sub

No.3 ベストアンサー 回答者： end-u 回答日時： 2008/10/26 11:58

>Set topRng = keyRng.End(xlDown).Offset(1)

keyRngにデータがあり、keyRngより下にデータがない場合
keyRng.End(xlDown)の時点でシートの最終行まで達しますので
.Offset(1)でエラーです。
コードを１ステップずつ実行して確認してみてください。



とりあえず、サブルーチンに分けてませんが

Option Explicit

Sub try2()
　　Const myDir = "D:\集計用\"
　　Dim MyName As String
　　Dim flg　　As Boolean
　　Dim kyRng　As Range
　　Dim myRng　As Range
　　Dim cnt　　As Long
　　
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　
　　Set kyRng = ActiveSheet.Range("A1")
　　MyName = Dir(myDir & "*.xls")
　　Do Until Len(MyName) = 0
　　　　With Workbooks.Open(myDir & MyName, updatelinks:=0, ReadOnly:=True)
　　　　　　With .Sheets(1)
　　　　　　　　Set myRng = .Range("D6").CurrentRegion
　　　　　　　　If myRng.Count > 1 Then
　　　　　　　　　　With .Range("D6", myRng.Cells(myRng.Count))
　　　　　　　　　　　　If flg Then
　　　　　　　　　　　　　　cnt = .Rows.Count - 1
　　　　　　　　　　　　　　.Offset(1).Copy
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　cnt = .Rows.Count
　　　　　　　　　　　　　　.Copy
　　　　　　　　　　　　End If
　　　　　　　　　　End With
　　　　　　　　　　kyRng.PasteSpecial xlPasteValues
　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　Set kyRng = kyRng.Offset(cnt)
　　　　　　　　　　flg = True
　　　　　　　　End If
　　　　　　End With
　　　　　　Set myRng = Nothing
　　　　　　.Close False
　　　　End With
　　　　MyName = Dir()
　　Loop

　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　Set kyRng = Nothing
　　MsgBox ("集計処理が終わりました")
End Sub

この回答への補足

ありがとうございます！
エラーは出なくなりました。が・・・新たな問題が・・・
注文書のD列は入力規制にてリストから商品を選ぶようにしています。
この方法に変えますと、入力していない行も入力規制をしているところまでコピーペーストされてしまい、集約したリストができません。
空白行を無視するとかいうコードが必要なのでしょうか？
すみません。何度も質問しまして・・・。教えて頂けるとありがたいです。宜しくお願い致します。

補足日時：2008/10/26 21:36

No.5 回答者： end-u 回答日時： 2008/10/27 11:41

必要な列数と、データの存在を判定する列が不変なら

Endプロパティを使った方が扱い易いのではないでしょうか。
下記、一例です。

Option Explicit

Sub try3()
　　Const fdName = "D:\集計用\" '処理フォルダ名
　　Const staR = 6　　　 '起点の行（D6の場合 6）
　　Const endC = 10　　　'データの最終列。変更必要。 10 は J列
　　Dim bkName As String 'Loop用処理Book名
　　Dim kyRng　As Range　'コピー先セル
　　Dim endR　 As Long　 '各集計データの最終行
　　Dim cnt　　As Long　 'コピー行数
　　Dim n　　　As Long　 '見だしOffset用

　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With

　　Set kyRng = ActiveSheet.Range("A1")
　　bkName = Dir(fdName & "*.xls")
　　Do Until Len(bkName) = 0
　　　　With Workbooks.Open(fdName & bkName, updatelinks:=0, ReadOnly:=True)
　　　　　　With .Sheets(1)
　　　　　　　　If .FilterMode Then .ShowAllData
　　　　　　　　.Rows.Hidden = False
　　　　　　　　'データ最終行取得
　　　　　　　　endR = .Cells(.Rows.Count, 4).End(xlUp).Row
　　　　　　　　'データがある時だけ処理する
　　　　　　　　If endR > staR Then
　　　　　　　　　　With .Range(.Cells(endR, 4), .Cells(staR + n, endC))
　　　　　　　　　　　　cnt = .Rows.Count
　　　　　　　　　　　　.Copy
　　　　　　　　　　End With
　　　　　　　　　　kyRng.PasteSpecial xlPasteValues
　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　Set kyRng = kyRng.Offset(cnt)
　　　　　　　　　　n = 1
　　　　　　　　End If
　　　　　　End With
　　　　　　.Close False
　　　　End With
　　　　bkName = Dir()
　　Loop

　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　Set kyRng = Nothing
　　MsgBox ("集計処理が終わりました")
End Sub

この回答へのお礼

いろいろな方法をご教授頂きありがとうございました。
一つ一つが勉強になりました。
締め切りが迫っていたため頼ってしまい、申し訳ございませんでした。
おかげさまで、思ったとおりの動きをするようになりました。
実はまだ問題がありますが、何とか頑張ってみようと思います。
ありがとうございました。

お礼日時：2008/10/27 23:18

No.4 回答者： end-u 回答日時： 2008/10/26 23:13

>この方法に変えますと、入力していない行も入力規制をしているところまでコピーペーストされてしまい、

ん？
Excelのバージョンはなんですか？2000と2007では再現しませんが。
元コードの
>Set mytbl = myRng.CurrentRegion
は一体なんだったんですか？
まる請けしたわけではないんですから、少しは自分で工夫する事もしないといけないでしょう。
仮に空白行があったとしても（解せませんが）、
全て転記されたあとに、A列が空白のセルを行全体削除すれば済む話では？

A列選択して[ctrl]キー+[g]キー同時押し。[ジャンプ]機能。
[セル選択]クリック、[空白セル]にチェックして[ok]。
右クリックメニュー[削除]、[行全体]にチェックして[ok]。
この動作をマクロ記録すれば参考コードは録れます。

On Error Resume Next
ActiveSheet.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

この回答への補足

すみません。
家に持ち帰ったので、Excel2000で作業していたのをExcel2003で引き続いて作成していました。

大変申し訳ございませんでした。

補足日時：2008/10/27 23:01

No.2 回答者： end-u 回答日時： 2008/10/24 17:58

>転記先のセルの開始位置の取得が間違っているのでしょうか？

そうかもしれませんね。

提示コードが標準モジュールに書かれている場合、
>Sub 転記(myRng, mytitle)
>　　Set keyRng = Range("A1")
ここでセットすると、被集計の各Bookを開いた状態ですから、
被集計の各BookのActiveSheet.Range("A1")をセットする事になります。

元のコードの流れをあまり変えないように整理してみると以下。

Option Explicit

Dim keyRng As Range

Sub try()
　　Const myDir = "D:\集計用\"
　　Dim mybook As Workbook
　　Dim MyName As String
　　Dim flg　　As Long
　　
　　Application.ScreenUpdating = False
　　Set keyRng = ActiveSheet.Range("A1")
　　MyName = Dir(myDir & "*.xls")
　　Do While MyName <> ""
　　　　Set mybook = Workbooks.Open(myDir & MyName, ReadOnly:=True)
　　　　Call 転記(mybook.Sheets(1).Range("D6"), flg)
　　　　flg = 1
　　　　mybook.Close savechanges:=False
　　　　MyName = Dir
　　Loop
　　Application.ScreenUpdating = True
　　MsgBox ("集計処理が終わりました")
　　
　　Set keyRng = Nothing
　　Set mybook = Nothing
End Sub

Sub 転記(myRng As Range, mytitle As Long)
　　Dim topRng As Range
　　
　　If keyRng.Value = "" And keyRng.Offset(1).Value = "" Then
　　　　Set topRng = keyRng
　　Else
　　　　Set topRng = keyRng.End(xlDown).Offset(1)
　　End If
　　With myRng.CurrentRegion
　　　　If mytitle = 0 Then
　　　　　　.Copy
　　　　Else
　　　　　　If .Rows.Count > 1 Then
　　　　　　　　.Offset(1).Resize(.Rows.Count - 1).Copy
　　　　　　End If
　　　　End If
　　　　topRng.PasteSpecial xlPasteValues
　　　　Application.CutCopyMode = False
　　End With

　　Set topRng = Nothing
End Sub

#被集計エリアの最左列のデータ状態によってはちょっと不安定な気もしますが。

この回答への補足

助け舟、ありがとうございます。
一度上手くいったのですが、コードは触っていないのに、
保存してまた実行すると、今度は

「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。」

というメッセージがでてしまいます。
下記部分Elseで。

If keyRng.Value = "" And keyRng.Offset(1).Value = "" Then
Set topRng = keyRng
Else
Set topRng = keyRng.End(xlDown).Offset(1)
End If

やはり組み方がまずいのでしょうか。お手上げ状態です。

補足日時：2008/10/26 00:26

No.1 回答者： FEX2053 回答日時： 2008/10/24 13:13

Sub 転記(myRng, mytitle)

この↑サブルーチンのなかにも、コピー処理があるんじゃないですか？

いずれにしたところで、VBAが絡む場合、シートに可能な限り結合
セルは作らないように設計するのが基本です。コピー処理をする時
場所によって、お示しのようなエラーが出ますので・・・。