vbaで特定の番号から番号の表データを抽出

質問

任意の範囲で表からデータを抽出することができるのでしょうか？
行は100行で列は7列、1行めは項目行で、1列目の2行目から１番から99番までが割り当てられています。1行目の2列目から7列目まで項目が割り当てられています。その他のセルには数値や文字データが入力されています。
こんな表から、任意に、例えば10行目から35行目までのセルデータ全てを別シートに取り出すそんな抽出方法があるのでしょうか？皆目検討がつきません。もし可能ならどなたかお教え頂けませんか？

回答No.7

mitarashi

#3です。
end-uさん、情報をありがとうございました。
下記の様なコードで別シートへの抽出が出来る事を確認いたしました。VBAの場合はコピー先がアクティブでなくても良いのですね。
Sub Macro4()
Sheets("Sheet2").Range("B1:C21").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet2").Range( _
"F1:G2"), CopyToRange:=Sheets("Sheet3").Range("B24:C24"), Unique:=False
End Sub

回答No.6

end-u

>任意に、例えば10行目から35行目までのセルデータ全てを別シートに取り出すそんな抽出方法があるのでしょうか？
そのようなケースの場合、『抽出』ではなく『コピー』と考えると、シンプルになるのではないでしょうか。
以下はActiveSheetからSheet2のA1セルにコピーする例。

Sub test()
　　Dim s As String
　　Dim r As Range

　　s = InputBox("コピーしたい行を 10:35 などのように。")
　　With ActiveSheet
　　　　On Error Resume Next
　　　　Set r = .Range("A2:G100").Rows(StrConv(s, vbNarrow))
　　　　On Error GoTo 0
　　　　If r Is Nothing Then MsgBox "不正値": Exit Sub
　　　　'Sheets("sheet2").UsedRange.ClearContents
　　　　Union(.Range("A1:G1"), r).Copy Sheets("sheet2").Range("A1")
　　End With

　　Set r = Nothing
End Sub

見出し行が不要な場合は差し替えです。
>Union(.Range("A1:G1"), r).Copy Sheets("sheet2").Range("A1")
r.Copy Sheets("sheet2").Range("A1")

コピー先が一定の場合、前回データをクリアする処理が必要です。
Sheets("sheet2").UsedRange.ClearContents など

#以下余談ですが
>mitarashiさん
AdvancedFilterメソッドは別シートへの抽出もできます。2000や97でも。
手動操作時にエラーが出るからそう思われる方もいらっしゃるようなのですが、
手動操作の場合は最初に抽出先のシートをActiveにして実行する事がキモです。

お礼

今回、多くの方に丁寧に質問を頂きました。ありがとうございます。vbaも一つの方法だけでなく、いろいろなやり方があるのだということも分かりました。一生懸命に勉強してみます。end-uさんの方法も試させて下さい。ありがとうございました。

回答No.5

ka_na_de

オートフィルターを使った一例です。

Sub test()
　　Dim Ws1 As Worksheet, Ws2 As Worksheet
　　Dim myStartRow As Long, myEndRow As Long

　　Set Ws1 = Sheets("Sheet1")
　　Set Ws2 = Sheets("Sheet2")

　　myStartRow = 10
　　myEndRow = 35

　　Ws2.Cells.Clear
　　With Ws1
　　　　If .AutoFilterMode Then
　　　　　　.AutoFilterMode = False
　　　　End If
　　　　With .Range("A1").CurrentRegion
　　　　　　.AutoFilter Field:=1, Criteria1:=">=" & myStartRow, _
　　　　　　　　　　　　　　Operator:=xlAnd, Criteria2:="<=" & myEndRow
　　　　　　.SpecialCells(xlCellTypeVisible).Copy Ws2.Range("A1")
　　　　End With
　　　　 .AutoFilterMode = False
　　End With

　　Set Ws1 = Nothing
　　Set Ws2 = Nothing
End Sub

お礼

コピーして貼り付けたら出来ました。ほんとにありがとうございます。

回答No.4

makho

あなたの環境と私の環境が違うと思いますのでコードは提示しません。
ＯＳ・バージョン　エクセルバージョン等によりＶＢが正常に動きません。
で、まずは親切なＶＢ解説ページが多数ありますので検索してご自分でコードを書いてみてください。
わからないところを質問すれば適切に回答がつくと思いますよ。

私も独学でデータ加工したり別シートに抽出するコードを書きました。
時間はかなりかかりましたが身につくとスキルとなりますから、回答ではなくアドバイスですいません。

お礼

おっしゃるとおりです。反省してます。でもこれを機会に徹底的にVBAを勉強してみます。ありがとうございました。

回答No.3

mitarashi

番号の列が設けてあるなら、フィルタオプションが良いでしょう。
http://allabout.co.jp/gm/gc/3501/3/
などをご参照下さい。
マクロを自動記録し、その次からは抽出条件だけ人力で書き換えた後、自動記録したマクロを実行すればOKです。
下記は自動記録の例
抽出条件設定をF1:番号、G1：番号、F2：>=10、G2:<=35等と設定すれば良いでしょう。残念ながら、同一シート内にしか抽出できません。（少なくとも、XL2000では）
Sub Macro1()
Range("B1:C21").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"F1:G2"), CopyToRange:=Range("B24:C24"), Unique:=False
End Sub

お礼

ありがとうございます。挑戦してみます。結果は又お知らせします。
まずは、お礼を！

回答No.2

noname#99913

次のコードを試してください。

初めに開始行と終了行を聞かれます。指定した行の間を、Sheet2の1行目からに書き込みます。r2の初期値を変えれば、書き込む行を変えられます。

Sub GetData()
Dim r1 As Integer
Dim c1 As Integer
Dim r2 As Integer
Dim c2 As Integer
Dim s As Integer
Dim e As Integer
s = Val(InputBox("開始行？"))
If s = 0 Then End
e = Val(InputBox("終了行？"))
If e = 0 Then End
r2 = 1
For r1 = s To e
c2 = 1
For c1 = 1 To 7
Sheets(2).Cells(r2, c2).Value = Sheets(1).Cells(r1, c1).Value
c2 = c2 + 1
Next c1
r2 = r2 + 1
Next r1
End Sub

お礼

なにやら、難しそうですが、挑戦してみる価値ありそうです。その結果は・・・又、お知らせします・・ありがとうございます！

回答No.1

gun_boxer

Hiro2010jpさんのやりたいことと、お持ちのスキルと、運用に添える形での実装が見えないのですが、VBAでいつも僕がやる方法を書いて見たいと思います。

最近のバージョンはわかりませんが、エクセルにはマクロ（=VBA）の記録、と言うものがあります。
（メニュー→ツール→マクロ→マクロの記録）
マクロの記録を開始させ、やりたい動作を行ない、終了と押すと、VisualBasicEditerにその操作のプログラムコードが書かれています。

記録ボタンを押してから、セルを選択したら、選択したセル範囲がプログラムソースのどこかに書いてあるはずなので、そこを都度変えるとか、A1とB1に書いたセルの範囲をコピーする、と言う指示に書き換えたらいかがでしょうか？

セル選択後にマクロの開始を押したら、selectedのエリアを、とか言う記録になりませんかね。こっちの方が実用的かも？

貼り付けるシートが同じであれば、そのシートクリックしてからコピペ操作をすればいいし、毎回新しいシートにコピーすればいいなら、シートを新規作成する動作ごとコピペしてしまえば、あとはソースみて修正するだけ、と言う話になってきますが、いかがでしょうか？
回答になってますでしょうか？

お礼

こんな早く回答頂けるとは全く思っていなかったんでホントビックリ！、そして感謝！です。できるかどうかとにかく試してみます。ありがとうございました！！