[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『日付指定＆文字列指定行を別シートに作成するマクロ』（のぞむ）
どうか助けてください。。
やりたいことは、以下の通りです。
Sheet1 元データに、
・A列〜C列には、番号や各種項目。
・D列以降に日付ごとの実験結果(数字&文字列）が入力されている。
日付と文字列を指定すると、
その日付列に指定した文字列入っている行だけの
新しい表を別シートに作成したい。（元データはそのままにしたい。）
指定する文字列は、ただ今のところ３つ〜５つ程です。
＜具体例＞
（元データ）
A B C D E F G 1 - - - 1 2 3 4 2 1234 X X DD BB CC DD 3 2345 X X AA CC AA BB 4 3456 X X DD BB AA DD 5 4567 X X AA CC DD CC 6 5678 X X AA AA CC DD 7 6789 X X DD BB AA BB 8 7890 X X BB BB BB AA 9 8901 X X AA CC CC BB . . ↓ 【日付】3日 【指定文字列】CCとAA と指定すると・・・
（別シート）
A B C D E F G 1 - - - 1 2 3 4 2 1234 X X DD BB CC DD 3 2345 X X AA CC AA BB 4 3456 X X DD BB AA DD 5 5678 X X AA AA CC DD 6 6789 X X DD BB AA BB 7 8901 X X AA CC CC BB
日付と文字列の指定方法は、
◆どこかに専用のセルを作成し、その横にマクロを登録したボタンを置いて、
専用セルに日付と文字列を入力した後、マクロ登録ボタンを押したら別シートが出来る。
◆ユーザーフォームを利用し、
マクロ登録ボタンを押すとユーザーフォームが出てきて、
そこの欄に日付と文字列を入力して、実行ボタンを押すと別シートが出来る。
などをイメージしております。
可能であれば、今後の勉強のため、
ユーザーフォームを利用した方法をご教示頂けると幸いです。
何卒よろしくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
1行目の日付は 単純な数字で 1,2,3 なんですか？ それとも日付型で表示書式で 1,2,3 になっているんですか？ それと、1,2,3,・・・・と最後まで連続してあるのですか？ それとも 1,2,4,5,8,10,25,・・・ といったように実験日だけになっているのですか？
（β） 2015/01/28(水) 14:21
そうですね。ぴったりだと思います。
（β） 2015/01/28(水) 14:38
前提として 1行目が D1から右に、連続して、31まで入っているものとします。 元シート名、転記シート名は実際のものになおしてください。
Sub Test()
Dim n As Long
Dim s As String
Dim v As Variant
Dim r As Range
Dim c As Range
Do
n = Application.InputBox("日付を1〜31でいれてください", Type:=1)
If n = 0 Then Exit Sub 'キャンセルボタン
If n >= 1 And n <= 31 Then Exit Do
Loop
s = Application.InputBox("抽出コードをいれてください。" & vbLf & "AA,BB,CC のように複数指定可能です。", Type:=2)
If s = "False" Then Exit Sub
v = Split(s, ",")
Set r = Sheets("Sheet1").Range("A1").CurrentRegion '元シート
With Sheets("Sheet2") '転記シート
.Cells.Clear
r.Rows(1).Copy .Range("A1")
Set c = .Cells(1, r.Columns.Count + 2)
c.Value = .Range("D1").Offset(, n - 1).Value
c.Offset(1).Resize(UBound(v) + 1).Value = WorksheetFunction.Transpose(v)
r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
c.EntireColumn.Clear
.Select
End With
End Sub
（β） 2015/01/28(水) 14:51
熱意はかうけど、一歩、一歩がいいのでは？
そう思うけど、とりあえず、その勉強材料として。
UserForm1 のうえに TextBox1 と ListBox1 と CommandButton1 を配置。 ListBox1にコードが表示されるので選択。Ctrlを押しながら複数選択可能。 また、何かを選び、そのあとShiftキーを押して別のものを選ぶと、その範囲がすべて選ばれる。 TextBox1には 1〜31 の数字を入力。入力が終わったらCommandButton1をクリック。
「標準モジュール」
Sub Test2()
UserForm1.Show
End Sub
「ユーザーフォームモジュール」
Private Sub UserForm_Initialize()
Dim dic As Object
Dim c As Range
Dim r As Range
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1").Range("A1").CurrentRegion '元シート
Set r = .Cells.Offset(1, 3).Resize(.Rows.Count - 1, .Columns.Count - 3)
For Each c In r
dic(c.Value) = True
Next
End With
With ListBox1
.MultiSelect = fmMultiSelectExtended
.List = dic.keys
End With
Set dic = Nothing
End Sub
Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim ok As Boolean
Dim n As Variant
With TextBox1
n = .Value
If IsNumeric(n) Then
If n >= 1 And n <= 31 Then ok = True
End If
If ok Then Exit Sub
MsgBox "1〜31の数字で入れてください"
Cancel = True
.SelStart = 0
.SelLength = Len(.Value)
End With
End Sub
Private Sub CommandButton1_Click()
Dim i As Long
Dim n As Long
Dim s As String
Dim v() As Variant
Dim r As Range
Dim c As Range
Dim x As Long
If Len(TextBox1.Value) = 0 Then
MsgBox "日付が未入力です"
Exit Sub
End If
n = TextBox1.Value
ReDim v(1 To ListBox1.ListCount)
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) Then
x = x + 1
v(x) = ListBox1.List(i - 1)
End If
Next
If x = 0 Then
MsgBox "抽出コードが選択されていません "
Exit Sub
End If
ReDim Preserve v(1 To x)
Set r = Sheets("Sheet1").Range("A1").CurrentRegion '元シート
With Sheets("Sheet2") '転記シート
.Cells.Clear
r.Rows(1).Copy .Range("A1")
Set c = .Cells(1, r.Columns.Count + 2)
c.Value = .Range("D1").Offset(, n - 1).Value
c.Offset(1).Resize(UBound(v)).Value = WorksheetFunction.Transpose(v)
r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
c.EntireColumn.Clear
.Select
End With
Unload Me
End Sub
（β） 2015/01/28(水) 15:43
すぐにご回答頂きありがとうございます！
早速検索したところ以下の応用できそうなコードを発見しました！
しかし、1行目に日付が入ってしまっているのですが、
この日付を同じように抽出条件シートに入力して指定するにはどのようにコードを書き直せばよろしいでしょうか…？
(例）抽出条件シートに
A B C D 1 日付 結果 B列項目 C列項目 2 1/1 AA 3 CC
==========
Sub フィルタオプション（）
Dim myData as range
Dimmycriteria as range
'「データ」シートのデータ範囲をmydataという変数に入れる
Set myData=Worksheets("データ").range("A1").Currentregion
'「抽出条件」シートの抽出条件の設定範囲をmyCriteriaという変数に入れる
Set myCriteria=Worksheets("抽出条件").range("A1").Currentregion
'「抽出」シートで
With Worksheets（"抽出"）
’抽出データをクリアする
.Cells.Clear
'myDataをデータ範囲としてmyRangeを抽出条件として
’フィルタオプションで「抽出」シートのA3セル基準に抽出
myData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=myCriteria,_
CopyToRange:=Range("A3"),Unique:=False
End with
EndSub
==========
βさん
こんなにすぐに回答をいただけるとは…感謝です！
早速やってみたところばっちり動きました！！
大変恐縮ですが、以下の点について教えて頂けますでしょうか？
・日付表示が実は、1/1,1/2・・・というようにしたかったです。。。すみません。
どのようにコードを変更すればよろしいでしょうか？
・抽出コードを"AA"としたところ"AAA"も一緒に出てきてしまいます。。
完全一致でいいのですが、その場合はどうすればいいでしょうか＞＜？
・今回ご教示頂いた抽出コードを都度選ぶマクロと抽出コードを
（たとえば）"AA"と"CC"を出す機会が圧倒的に多いので、日付指定だけする
マクロも作りたい場合は、どこを省略すればいいでしょうか？
串さんからご提案頂いた、フィルターオプションのマクロ化にして
デフォルトで"AA"と"CC"をセルに入力するようにしておけば解決するでしょうか？
お忙しいところ本当に申し訳ございませんが、
初心者なものでどうか今一度ご教示お願い致します。
（のぞむ） 2015/01/29(木) 13:36
日付について、ダイアログで指定する日付のことをいってる？ もし、そうじゃなく、シート上の日付の値のことなら、コードでは、日付をチェックせず、 ダイアログで入力された1〜31の数字から、Ｄ列以降のどの列かを判断しているので変更は不要。
抽出コードについては、もし、デフォルトが常に AA,BB だとして、それをダイアログ表示の際に、セットしてやり 変更なければ、そのままＯＫをおすというのは、いかがですか。
部分一致から、完全一致の件、了解。
で、以下で試してみてください。
Sub Test()
Dim n As Long
Dim s As String
Dim v As Variant
Dim r As Range
Dim c As Range
Dim x As Long
Do
n = Application.InputBox("日付を1〜31でいれてください", Type:=1)
If n = 0 Then Exit Sub 'キャンセルボタン
If n >= 1 And n <= 31 Then Exit Do
Loop
s = Application.InputBox("抽出コードをいれてください。" & vbLf & "AA,BB,CC のように複数指定可能です。", Default:="AA,BB", Type:=2)
If s = "False" Then Exit Sub
v = Split(s, ",")
For x = LBound(v) To UBound(v)
v(x) = "=""=" & v(x) & """"
Next
Set r = Sheets("Sheet1").Range("A1").CurrentRegion '元シート
With Sheets("Sheet2") '転記シート
.Cells.Clear
r.Rows(1).Copy .Range("A1")
Set c = .Cells(1, r.Columns.Count + 2)
c.Value = .Range("D1").Offset(, n - 1).Value
c.Offset(1).Resize(UBound(v) + 1).Value = WorksheetFunction.Transpose(v)
r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=c.CurrentRegion, _
CopyToRange:=.Rows(1).Resize(1, r.Columns.Count), Unique:=False
c.EntireColumn.Clear
.Select
End With
End Sub
（β） 2015/01/29(木) 13:57
A 1 1/1 2 AA 3 CC 4
（串） 2015/01/29(木) 17:49
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.