エクセルで複数のブックの一部を抽出する

エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？
merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、
課名D16
商品名B20:B39
枚数H20:H39
金額I20:I39
の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？
もとのブックの行数は決まっています。
どうか力を貸してください。よろしくお願いします。
Sub test02()
Dim MyFile As String, MyPath As String '変数宣言
Dim x As Long, y As Long
Dim wb As Workbook, tb As Workbook
Dim ka As String
Dim sh1, sh2
Set tb = ThisWorkbook
MyPath = tb.Path & "\" '自分のパスを取得
MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル
Application.ScreenUpdating = False '画面更新停止
Application.Calculation = xlCalculationManual '自動計算停止
Do While MyFile <> "" 'エクセルファイルがなくなるまで
If MyFile <> tb.Name Then '自分以外のファイルを対象
Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く
With ActiveSheet
ka = .Range("D16").Value '課名取得
x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
sh1 = .Range("B20:B" & x).Value '商品名取得
sh2 = .Range("H20:I" & x).Value '数量＆金額取得
End With
With tb.Sheets("Sheet1")
y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
y = IIf(.Range("B" & y) = "", y, y + 1)
If x >= 20 Then '納品書B20以下にデータがあれば
Set myRng = .Range("A" & y).Resize(x - 19, 1)
myRng.Value = ka '課名転記
myRng.Offset(, 1).Value = sh1 '商品名転記
myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記
End If
End With
wb.Close (False) '選択したファイルを閉じる
End If
MyFile = Dir() '次のファイルを検索
Loop '繰り返し
Application.Calculation = xlCalculationAutomatic '自動計算停止解除
Application.ScreenUpdating = True '画面更新停止解除
Set tb = Nothing
Set wb = Nothing
Set myRng = Nothing
End Sub

No.1 ベストアンサー 回答者： hige_082 回答日時： 2010/01/16 22:07

質問の内容がよく分かりませんが

＞・・・これを参考にして作っているのですが、
変更部分は？
＞元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？
＞・・・の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？
例を挙げて説明した方がわかりやすいかも

以上よく分ってませんが
この様なことがしたいのかな？

　　　　　　：
　　　　　　：
Set myRng = .Range("A" & y).Resize(x - 19, 1)
myRng.Value = ka '課名転記
myRng.Offset(, 1).Value = sh1 '商品名転記
myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記
　　　　　　：
　　　　　　：
　　　　　↓　↓
　　　　　　：
　　　　　　：
Set myRng = .Range("A" & y)
myRng.Value = ka '課名転記
myRng.Offset(, 1).Value = WorksheetFunction.Transpose(sh1) '商品名転記
myRng.End(xlToRight).Offset(, 1).Value = WorksheetFunction.Transpose(sh2) '数量＆金額転記
　　　　　　：
　　　　　　：

参考になりますか

この回答への補足

すみません自己解決？しました。Bに設定しているところをAに変えることで（Aは日付で空白はないので）すべてのデータが抽出されました。
根本的な解決ではないのかもしれませんが、、。
ありがとうございました。

補足日時：2010/01/17 02:33

この回答へのお礼

どうもありがとうございました。
shが10まであるのですが、最後は
myRng.End(xlToRight).Offset(, 10).Value = WorksheetFunction.Transpose(sh10) ではなくそのまま
myRng.Offset(, 10).Value = WorksheetFunction.Transpose(sh10)
でうまくいきました。只、Bの列に空白があるとそのブックは読み込まれません。空白に-などを入れればいいのですが、もしお分かりでしたらお願いします。現在以下のようになっています。
ka = .Range("k2").Value '日付取得
x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
sh1 = .Range("B33:B38" & x).Value
sh2 = .Range("C33:C38" & x).Value
sh3 = .Range("D33:D38" & x).Value
sh4 = .Range("E33:E38" & x).Value
sh5 = .Range("F33:F38" & x).Value
sh6 = .Range("G33:G38" & x).Value
sh7 = .Range("H33:H38" & x).Value
sh8 = .Range("I33:I38" & x).Value
sh9 = .Range("J33:J38" & x).Value
sh10 = .Range("K33:K38" & x).Value
End With
With tb.Sheets("Sheet1")
y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得
y = IIf(.Range("B" & y) = "", y, y + 1)
If x >= 20 Then 'B20以下にデータがあれば
Set myRng = .Range("A" & y) '.Resize(x - 19, 1)
myRng.Value = ka
myRng.Offset(, 1).Value = WorksheetFunction.Transpose(sh1)
myRng.Offset(, 2).Value = WorksheetFunction.Transpose(sh2)
myRng.Offset(, 3).Value = WorksheetFunction.Transpose(sh3)
myRng.Offset(, 4).Value = WorksheetFunction.Transpose(sh4)
myRng.Offset(, 5).Value = WorksheetFunction.Transpose(sh5)
myRng.Offset(, 6).Value = WorksheetFunction.Transpose(sh6)
myRng.Offset(, 7).Value = WorksheetFunction.Transpose(sh7)
myRng.Offset(, 8).Value = WorksheetFunction.Transpose(sh8)
myRng.Offset(, 9).Value = WorksheetFunction.Transpose(sh9)
myRng.Offset(, 10).Value = WorksheetFunction.Transpose(sh10)
説明不足ですみませんでした。

お礼日時：2010/01/17 02:09