VBA 他ブックのセルの値を１セルずつ代入したい

質問

昨日↓でお世話になりました。
http://oshiete1.goo.ne.jp/qa4299999.html

おかげさまでだいぶ先に進むことができました。
ですがまた行き詰ってしまったので、お力を借りれたらと思い質問させていただきます。

昨日ご教授いただいたコードでは、「管理表.xls」のコマンドボタンを押すと、同一フォルダ内にあるブック「*予定表*.xls」内のシート「*予定?」の固定の範囲
「G2,H2,N3,O3」を「管理表.xls、sheet2、A1:D4」に
「B14:I44」を「管理表.xls、sheet2、A2:H32」に
まだファイル、シートがある場合はループでそれらの次の行に値をいれていくことができたのですが、固定範囲のうちの「G2,H2,N3,O3」を、「管理表.xls、sheet2、A2:H32」のA～D列全てに付けたいのです。
なんかわかりづらい表現になってしまいましたが、

____Ａ___Ｂ___Ｃ___Ｄ____Ｅ____Ｆ____Ｇ____Ｈ____Ｉ____Ｊ_____Ｋ____Ｌ
１ G2 G2 N2 O3 B14 C14 D14 E14 F14 G14 H14 I14
２ G2 G2 N2 O3 B15 C15 D15 E15 F15 G15 H15 I15
３ G2 G2 N2 O3 B16 C16 D16 E16 F16 G16 H16 I16
　　　　　　　　　　　　・
　　　　　　　　　　　　・
　　　　　　　　　　　　・

という感じにしたいんです。どうかご教授お願いします。
一応コードを載せておきます。

Sub 予定()

Dim Pn As String
Dim Fn As String
Dim ws As Worksheet
Dim r As Range
Dim v, i As Integer

Pn = ActiveWorkbook.Path
ChDir Pn

Fn = Dir("*予定表*.xls")

v = Array("N3", "O3", "G2", "H2")

Set r = ThisWorkbook.Worksheets("Sheet2").Range("A1")

Do Until Fn = ""

Workbooks.Open Filename:=Fn

For Each ws In Worksheets

If ws.Name Like "*予定?" Then
With ws
For i = 0 To 3
r.Offset(0, i).Value = .Range(v(i)).Value

Next

r.Offset(1).Resize(31, 8).Value = .Range("B14:I44").Value
Set r = r.End(xlDown).Offset(1)

End With

End If

Next

Workbooks(Fn).Close SaveChanges:=False

Fn = Dir()

Loop

End Sub

++++++++++++++++++++
OS ⇒Windows XP
Version⇒Excel 2000
++++++++++++++++++++

回答No.3

n-jun · ベストアンサー

>上かつ、N2、O3は文字列なのでstringにしたいんです。

サンプルです。

Sub　test2()
　Dim　ws　As　Worksheet
　Dim　r　As　Range
　Dim　v,　i　As　Integer

　v　=　Array("N3",　"G2")

　Set　r　=　Worksheets("Sheet2").Range("A1")　　　　　　　'貼り付けるのは１行目から？
　Worksheets("Sheet2").Range("A:B").NumberFormatLocal　=　"@"　　'文字列設定

　For　Each　ws　In　Worksheets
　　　　　If　ws.Name　Like　"*予定?"　Then
　　　　　　　　With　ws
　　　　　　　　　　　　　For　i　=　0　To　1
　　　　　　　　　　　　　　　　　r.Offset(,　i　*　2).Resize(31,　2).Value　=　.Range(v(i),　.Range(v(i)).Offset(,　1)).Value
　　　　　　　　　　　　　Next
　　　　　　　　　　　　　r.Offset(,　4).Resize(31,　8).Value　=　.Range("B14:I44").Value
　　　　　　　　　　　　　Set　r　=　r.End(xlDown).Offset(1)
　　　　　　　　End　With
　　　　　End　If
　Next
　Set　r　=　Nothing
End　Sub

お礼

n-junさん、いつもありがとうございます！
おかげさまでできました！
本当に助かります！
どうもありがとうございました！！！

回答No.2

n-jun

ANo.1です。

取り敢えずのサンプル。（解釈が違っていたらすいません）

Sub　test()
　Dim　ws　As　Worksheet
　Dim　r　As　Range
　Dim　v,　i　As　Integer

　v　=　Array("G2",　"N3")

　Set　r　=　Worksheets("Sheet2").Range("A1")　　'貼り付けるのは１行目から？

　For　Each　ws　In　Worksheets
　　　　　If　ws.Name　Like　"*予定?"　Then
　　　　　　　　With　ws
　　　　　　　　　　　　　r.Resize(31,　1).Value　=　.Range(v(0)).Value
　　　　　　　　　　　　　For　i　=　0　To　1
　　　　　　　　　　　　　　　　　r.Offset(,　i　*　2　+　1).Resize(31,　2).Value　=　.Range(v(i),　.Range(v(i)).Offset(,　1)).Value
　　　　　　　　　　　　　Next
　　　　　　　　　　　　　r.Offset(,　5).Resize(31,　8).Value　=　.Range("B14:I44").Value
　　　　　　　　　　　　　Set　r　=　r.End(xlDown).Offset(1)
　　　　　　　　End　With
　　　　　End　If
　Next
　Set　r　=　Nothing
End　Sub

回答No.1

n-jun

>____Ａ___Ｂ___Ｃ___Ｄ____Ｅ____Ｆ____Ｇ____Ｈ____Ｉ____Ｊ_____Ｋ____Ｌ
>１ G2 G2 N2 O3 B14 C14 D14 E14 F14 G14 H14 I14
Ａ列とＢ列が同じなのはミス？それとも正解？
Ｃ列がN2なのはミス？それとも正解？

お礼

こっちにすいません。
上かつ、N2、O3は文字列なのでstringにしたいんです。
昨日に引き続きすいません。

補足

n-junさん、昨日は本当にお世話になりました！
失礼しました。

＿＿Ａ＿Ｂ＿Ｃ＿Ｄ
１＿N3＿O3＿G2＿H2・・・
２＿N3＿O3＿G2＿H2・・・
でした。すいません。