ＶＢＡでのデータの値を選択する事について

質問

Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ　　　Ｆ　　　Ｇ
１　１０　　１５　　　　　　　９　　　２３　　３３　　５５
２　　　　　　　　　　　　　１０　　　３３　　４４　　５６
３　　　　　　　　　　　　　１１　　　４４　　５５　　５７　　　　　　　　　　　
４　　　　　　　　　　　　　１２　　　５５　　６６　　７６
５　　　　　　　　　　　　　１３　　　２３　　７７　　８７
６　　　　　　　　　　　　　１４　　　３３　　８８　　８８
７　　　　　　　　　　　　　１５　　　４５　　９９　　９９
８　　　　　　　　　　　　　１６　　　５５　　２１　　５６
９　　　　　　　　　　　　　１７　　　６６　　４５　　７６
１０　　　　　　　　　　　　１８　　　７７　　５２　　５４

質問です
Ａ１の値が１０
Ｂ１の値が１５
でＡ１とＢ１の値は各データによって異なって入力されています。
決まりとしては、
Ａ１＜Ｂ１で,
必ず、Ａ１の値とＢ１の値はＤ列に存在します。

Ａ１の値とＢ１の値をマクロで取得し、
Ｄ列でその選択範囲を検索し、Ｄ列の１０～１５の値の選択範囲で、
Ｄ２：Ｇ７までをうまくコピーし、違う場所に張り付けしたいのです。
もし、詳しい方がいらっしゃいまして、簡単にできる方法がありましたら、
ご指導の程お願い致します。

回答No.3

mu2011 · ベストアンサー

一例です。
H1以下に値だけ貼り付けをしていますので調整して下さい。
因みにＤ列の値は昇順になっている事が前提です。

Sub sample()
If Cells(1, "A") > 0 And Cells(1, "B") > 0 Then
Set st = Range("D:D").Find(Cells(1, "A"))
Set ed = Range("D:D").Find(Cells(1, "B"))
st.Resize(ed.Row - st.Row + 1, 4).Copy
Range("H1").PasteSpecial Paste:=xlPasteValues '貼り付け先
Application.CutCopyMode = False
End If
End Sub

お礼

ありがとうございます。お忙しい中すみません。

st.Resize(ed.Row - st.Row + 1, 4).Copy
の部分で
『オブジェクト変数または With ブロック変数が設定されていません。(Error 91)』
と表示がでました。どのようにたいしょしたらよろしいでしょうか？

回答No.7

mu2011

no3です。
>～。(Error 91)』
　⇒Ａ１，Ｂ１のデータが見つからない場合、このエラーになります。
　　Set ed ～文の直後に以下のコードを挿入して下さい。　
　　If st Is Nothing Or ed Is Nothing Then MsgBox "Not found": End
　　このメッセージが出力されると思いますので「A1,B1、Ｄ列」データを確認して下さい。

お礼

「A1,B1、Ｄ列」データを確認すると出来ました。
ありがとうございました。

回答No.6

KURUMITO

次のようなマクロではいかがでしょう。

Sub 選択範囲のコピー貼り付け()
Dim Harituke As String
Dim i As Integer
Dim Row1 As Integer
Dim Row2 As Integer
Application.ScreenUpdating = False
Harituke = InputBox("コピーして貼り付ける時の貼り付け先のセル番号(A10のように）を入力してください。")
For i = 1 To 10
If Cells(i, "D") = Range("A1").Value Then
Row1 = i
End If
If Cells(i, "D") = Range("B1").Value Then
Row2 = i
Exit For
End If
Next
Range(Cells(Row1, "D"), Cells(Row2, "G")).Select
Selection.Copy
Range(Harituke).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range(Harituke).Select
Application.ScreenUpdating = True
End Sub

回答No.5

noname#192389

繰り返している時に、それぞれの数値はどうなってますか？

Debug.Print
この文はコードの下部にあるイミディエイトと書かれたウインドウに
後に書いたものの値を表示するものです。

Debug.Print source.Offset(i, 0).Cells(1, 1).Value

とすれば、
source.Offset(i, 0).Cells(1, 1).Value
の値が下部に表示されるはずですが、
どのような表示になっていますか？

お礼

解決しました。ありがとうございました。

回答No.4

noname#192389

オーバフローということは、
minnum又はmaxnumが正しく取得できていないか
又は
source.Offset(i, 0).Cells(1, 1).Value
が違う部分を参照しているかのどちらかで、

source.Offset(i, 0).Cells(1, 1).Value = minnum

ここが（ｊの部分も同じ）イコールにならず、
永久ループになっています。

minnum = Worksheets("sheet1").Range("A1").Value
maxnum = Worksheets("sheet1").Range("B1").Value
の下に
Debug.Print minnum
Debug.Print maxnum
と書く。

あと、
i = i + 1
の上に
Debug.Print source.Offset(i, 0).Cells(1, 1).Value
そして
j = j + 1
の上に
Debug.Print source.Offset(j, 0).Cells(1, 1).Value
と書いてください。

そこで、Ｆ８キーで実行（Ｆ８キーを押すごとに１行ずつ実行されます）しながら、
イミディエイトウインドウで、
それぞれが正しいか確認します。

お礼

ご回答ありがとうございます。
再度ご指摘いただいた内容を加えて、Ｆ８キーで１行ずつ実行していくと、

Do Until source.Offset(i, 0).Cells(1, 1).Value = minnum

Debug.Print source.Offset(i, 0).Cells(1, 1).Value

i = i + 1
Loop

の部分で繰り返されている様子でした。
そして、
i = i + 1
のところで
オーバフローのデバッグが生じる様子でした。

回答No.2

noname#192389

黄色い表示（デバッグ箇所）になるのは
j = j + 1
のことろですか？
単に１を足しているだけなのですが・・・

Excel2003とExcel2007で正常動作を確認しました。
エラーメッセージにはどのように表示されていますか？

お礼

i=i+１　あるいは
j = j + 1　のところで
オーバーフローしました。(Error 6)
とデバッグが生じました。
どのような原因が考えられますか？

回答No.1

noname#192389

chi-pan-kun さん、
たぶん経理系のツールということで経理カテゴリにされたと思いますが、
こういう質問はMSofficeのカテゴリで質問した方が回答がきやすいですよ。
・・・・といいつつ回答してしまいますが（笑）

Public Sub SelectAreaCopy()
Dim minnum As Variant 'A1から取得する値（最小値）
Dim maxnum As Variant 'B1から取得する値（最大値）
Dim source As Range 'コピー元のテーブル全体

minnum = Worksheets("sheet1").Range("A1").Value
maxnum = Worksheets("sheet1").Range("B1").Value

Worksheets("sheet1").Range("D1").Activate

Set source = ActiveCell.CurrentRegion
Dim i As Integer 'コピー元の一番上の行
Dim j As Integer 'コピー元の一番下の行
i = 0
Do Until source.Offset(i, 0).Cells(1, 1).Value = minnum
i = i + 1
Loop

j = i

Do Until source.Offset(j, 0).Cells(1, 1).Value = maxnum
j = j + 1
Loop
source.Offset(i, 0).Resize(j - i + 1, source.Columns.Count).Select
Selection.Copy

Worksheets("sheet2").Paste Destination:=Worksheets("sheet2").Range("A1")

End Sub

こんなプログラムでしょうか。
コピー元はsheet1、コピー先はsheet2のA1ということで作成してあります。
最後の行の
Worksheets("sheet2")
は実際のコピー先のシートに
Worksheets("sheet2").Range("A1")
を実際のコピー先範囲の左上のセルに変更してください。

お礼

ご丁寧に早速のご返答ありがとうございます。
このマクロでやってみましたが、自分のやり方がまずいのか、
j=j+１のところで、デバッグになってしまいます。
何かやり方がまずかったでしょうか？？