[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『日付指定&文字列指定行を別シートに作成するマクロ』(のぞむ)
どうか助けてください。。
やりたいことは、以下の通りです。
Sheet1 元データに、
・A列〜C列には、番号や各種項目。
・D列以降に日付ごとの実験結果(数字&文字列)が入力されている。
日付と文字列を指定すると、
その日付列に指定した文字列入っている行だけの
新しい表を別シートに作成したい。(元データはそのままにしたい。)
指定する文字列は、ただ今のところ3つ〜5つ程です。
<具体例>
(元データ)
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の数字から、D列以降のどの列かを判断しているので変更は不要。
抽出コードについては、もし、デフォルトが常に AA,BB だとして、それをダイアログ表示の際に、セットしてやり 変更なければ、そのままOKをおすというのは、いかがですか。
部分一致から、完全一致の件、了解。
で、以下で試してみてください。
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.