エクセルのマクロについて困っています。２

質問

エクセルのマクロについて困っています。２

見てくださり有難うございます。
前回と似た内容の質問ですが、すみません。
前回の内容です。→　http://okwave.jp/qa/q5906335.html

私がマクロで行いたい作業が「場所と日付を検索、さらに要らない列を消し、別シートに表示したい」というものです。
以下の表を作ってみました。
検索したい→A列・B列
削除したい→C列・F列

　　　　A　　　　　B　　　　　　　　　C　　　　　　　D　　　　　　　E　　　　　F
1　　場　所　　　日　付　　　　使用機械　　　　作業内容　　　 工数(H) 　　備　考
2　　 東京 2010/05/19　　　　　 R形　　　　　　掃除　　　　　1.00　　　　なし
3　　 新潟 2010/05/17　　　　　 L形　　　　　　塗布　　　　　6.00　　　　なし
4　　 東京 2010/06/01　　　　　 L　　　　　　　掃除　　　　　2.50　　　　なし
5　　 東京 2010/06/01　　　　　 L形　　　　　　掃除　　　　　1.00　　　　なし
6　　 神戸 2010/05/18　　　　　 R形　　　　　　塗布　　　　　7.00　　　　なし
7　　 新潟 2010/06/01　　 　　　 L形　　　　　　塗布　　　　　7.50　　　　なし
8　　 東京 2010/05/11　　　　　 F形　　　　　　掃除　　　　　2.00　　　　なし
9　　 神戸 2010/06/01　　　　　 L形　　　　　　掃除　　　　　1.00　　　　なし
10　　 神戸 2010/05/15　　　　　 L形　　　　　　塗布　　　　　5.00　　　　なし

　　　　　　　　　　↓
（例）東京の５月分の検索をした場合の結果
　　　A　　　　　　　B　　　　　　　　C　　　　　　　D　　　　　
1　　場　所　　　　日付　　　　　　作業内容　　　 工数(H) 　　
2　　 東京 　　2010/05/11　　　　　掃除　　　　　2.00　　　　
3　　 東京 　　2010/05/19　　　　　掃除　　　　　1.00　　　

こうなるようにプログラムをくみたいです。前回の応用も含め、自分なりに組んでみましたがうまくいきません。どこがだめでしょうか？（回答欄にコードを入れますので見てもらえるとうれしいです。
また、こっちのやり方の方がいいんじゃない？というのがありましたら教えていただけますよう宜しくお願い致します。

回答No.5

myRange · ベストアンサー

初心者用コードということで。。。

'---------------------------------------------
■データシート：　Sheet1
見出し行＿＿：　１行目
データ行＿＿：　２行目以降
'---------------------------------------------
■抽出用シート：　Sheet2

＿＿＿Ａ＿＿＿＿Ｂ＿＿＿＿Ｃ＿＿＿＿＿Ｄ＿＿＿
１＿場＿所＿＿開始日＿＿終了日＿＿＿＿＿＿＿＿
２＿●●●＿＿●●●＿＿●●●＿＿＿＿＿＿＿＿
３
４
５＿場＿所＿＿日＿付＿＿作業内容＿＿工＿数＿＿
６
７

●●●に抽出条件を入れる

'---------------------------------------------------
Sub test()
　Dim R As Long
　Dim Row2 As Long '●Sheet2書込み行

　Sheets("Sheet2").Range("A5").CurrentRegion.Clear
　Sheets("Sheet2").Range("A5:D5").Value = Array("場所", "日付", "作業内容", "工数(H)")
　Row2 = 5

For R = 2 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
　If Sheets("Sheet1").Cells(R, "A") = Sheets("Sheet2").Range("A2") And _
　　　Sheets("Sheet1").Cells(R, "B") >= Sheets("Sheet2").Range("B2") And _
　　　Sheets("Sheet1").Cells(R, "B") <= Sheets("Sheet2").Range("C2") Then

　　　Row2 = Row2 + 1
　　　Sheets("Sheet2").Cells(Row2, "A").Value = Sheets("Sheet1").Cells(R, "A").Value
　　　Sheets("Sheet2").Cells(Row2, "B").Value = Sheets("Sheet1").Cells(R, "B").Value
　　　Sheets("Sheet2").Cells(Row2, "C").Value = Sheets("Sheet1").Cells(R, "D").Value
　　　Sheets("Sheet2").Cells(Row2, "D").Value = Sheets("Sheet1").Cells(R, "E").Value
　End If
Next R

'●結果の並べ替え
　If Row2 = 5 Then
　　　MsgBox "該当データなし！"
　Else
　　　Sheets("Sheet2").Range("A5:D" & Row2).Sort _
　　　　　Key1:=Range("B6"), Order1:=xlAscending, _
　　　　　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin
　End If

　Sheets("Sheet2").Select
End Sub
'----------------------------------------------------

以上です。

お礼

回答有難うございます！
コードを書いていただき有難うございます！
早速やってみます！

回答No.7

layy

「シート全体を選びコピーする」
「新しいシートへ貼り付け」
「Ｃ列、Ｆ列を削除する」
「１行目見出しをフィルタとする」
「Ｅ１１にSUBTOTAL関数を定義する」
「Ａ列フィルタオプションで、東京で始まるもの、となるよう条件チェックする」
「Ｂ列フィルタオプションで、2010/05で始まるもの、となるようチェックする」

EXCEL2007で実施しました。
コードを記載しなくても期待したものになる感じです。
ポイントは「SUBTOTAL関数」、
フィルタを考慮した合計を求めることができます。
フィルタでは「ｘｘｘから始まるものだけにする」、です。

ほか、いろいろ対応できる手段はありそうなので、
これを機にどれか１つでも理解して次回ほかでも使えるようにがんばりましょう。

お礼

回答有難うございます。
いろいろな方法があるんですね！
試してみます！

回答No.6

jcctaira

シンプルに作成してみました。

Sub 新シート作成()
　Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
　For 行 = Cells.SpecialCells(xlCellTypeLastCell).Row To 2 Step -1
　　If Cells(行, "A") <> "東京" Or Format(Cells(行, "B"), "YYYYMM") <> "201005" Then
　　　Cells(行, "A").EntireRow.Delete
　　End If
　Next 行
　Range("C:C,F:F").Delete
End Sub

【説明】
・元のシート（Sheet1）をブックの最後に複写します。
・全行をチェックし、東京、2001年05月　以外を削除します。
・C列、F列を削除します。

注）結果のシート名変更はしていませんので、変更するように修正して下さい。

お礼

回答有難うございます。
こんなやり方があったんですね！
早速試してみます。

回答No.4

Wendy02

前回のものを少し直せば済むと思います。
AutoFilter をフィルタオプション（AdvancedFilter) に切り替えただけです。
このマクロの基本路線のレベルは、日付のチェックなどの小技は別ですが、思いのほか、初級レベルです。
日付のチェックは、私のこだわりですが、ここのサイトで覚えたワザのひとつです。日付のエラーや誤作動はみっともないですからです。その代わり、場所の検索チェックはやめました。

#3のマクロは、Variant 型の宣言は、文字数制限のために省略しました。

また、エラーは出ていないはずですが、本来は、
With ActiveSheet
.Range("AA2").Formula = "=A2=""" & sPlc & """"
.Range("AB2").Formula = "=AND(" & CLng(sDate) & "<=B2," & CLng(eDate) & ">=B2)"
End With

と書かなくてはなりません。

お礼

回答有難うございます。
こんな技があったんですね！
試してみます。

回答No.3

Wendy02

'//説明は次の書き込みで
Sub SplitMcrR()
　　Dim sPlc
　　Dim sMon, sDate, eDate
　　Dim rng As Range
　　Dim ret
　　Dim NextSh As Worksheet
　　'データ範囲
　　Set rng = ActiveSheet.Range("A1").CurrentRegion
　　Set NextSh = Worksheets("Sheet2") '転送先
　　NextSh.UsedRange.Clear

　　If Application.CountA(rng) < 3 Then
　　　　MsgBox "シートが違うかもしれません。", 48
　　　　Exit Sub
　　End If
　　sPlc = Application.InputBox("場所は？", "検索", Type:=2)
　　If VarType(sPlc) = vbBoolean Or Trim(sPlc) = "" Then Exit Sub
　　sMon = Application.InputBox("月数は？ 1-12 または yyyy/m", "検索", Type:=2)
　　If VarType(sMon) = vbBoolean Or Trim(sMon) = "" Then Exit Sub

　　If Len(sMon) - Len(Replace(sMon, "/", "", , , 1)) = 1 And Len(sMon) > 5 Then
　　　　If IsDate(sMon & "/1") > 1 Then MsgBox "日付式が違います。", 48: Exit Sub
　　　　sDate = CDate(sMon & "/1"): eDate = DateSerial(Year(sDate), Month(sDate) + 1, 0)
　　ElseIf IsDate(sMon) Then
　　　　sDate = DateSerial(Year(Date), Month(sMon), 1): eDate = DateSerial(Year(Date), Month(sDate) + 1, 0)
　　ElseIf IsNumeric(sMon) Then
　　　　If Not (CLng(sMon) >= 1 And CLng(sMon) <= 12) Then
　　　　　　MsgBox "月数が違います。", 48: Exit Sub
　　　　Else
　　　　　　sDate = DateSerial(Year(Date), sMon, 1): eDate = DateSerial(Year(Date), Month(sDate) + 1, 0)
　　　　End If
　　Else
　　　　Exit Sub
　　End If
　　Range("AA2").Formula = "=A2=""" & sPlc & """"
　　Range("AB2").Formula = "=AND(" & CLng(sDate) & "<=B2," & CLng(eDate) & ">=B2)"

　　Application.ScreenUpdating = False
　　With rng
　　　　.AdvancedFilter Action:=xlFilterInPlace, _
　　　　CriteriaRange:=Range("AA1:AB2"), _
　　　　Unique:=False
　　End With
　　With ActiveSheet
　　　　If Application.Subtotal(3, rng.Columns(1)) = 1 Then
　　　　　　MsgBox "該当データが見当たりません。", 48
　　　　　　.ShowAllData
　　　　　　.Range("AA1:AB2").ClearContents
　　　　　　Exit Sub
　　　　End If
　　　　.Columns(3).Hidden = True: .Columns(6).Hidden = True
　　　　rng.Copy NextSh.Range("A1") '転送
　　　　.Columns(3).Hidden = False: .Columns(6).Hidden = False
　　　　.ShowAllData
　　　　.Range("AA1:AB2").ClearContents
　　End With
　　Application.ScreenUpdating = True
　　NextSh.Activate
End Sub

お礼

コード有難うございます！

回答No.2

layy

絞り込む日付は、月だけの指定、日付の開始終了範囲指定、日の指定、考えられますが、月指定ですね？。結果は並び変わっていますが日付順ででないとダメですか？。フィルタの操作は知っていますか？。情報の追加お願いします。

お礼

回答有難うございます。

＞絞り込む日付は、月だけの指定、日付の開始終了範囲指定、日の指定、考えられますが、月指定ですね？

はい、そうです。

＞結果は並び変わっていますが日付順ででないとダメですか？。

できれば、ですが、出来なければ順番は変わらなくても平気です。

＞フィルタの操作は知っていますか？。

知っています。ですが、フィルタで日付の開始終了を指定し、検索はできないのでマクロが便利かとおもいました。

言葉不足、情報不足が直っていませんでした。申し訳ありません。

回答No.1

t_nojiri

>回答欄にコードを入れますので見てもらえるとうれしいです

質問欄に入れて下さい。何処が上手く行ってないのかソースが無いのに聞くんじゃ
前回の質問と変わらないです。

お礼

回答有難うございます。
質問欄の文章が長くなったので違う欄のほうがいいかな？と思い別にしましたが、書き込めませんでした。
今度からはすべて一緒にしますね。

これが載せようと思ったものです。

Sub 検索()

Dim Search1 As String
Dim Search2 As String
Dim S1() As String
Dim S2() As String
Dim SV1 As Variant
Dim SV2 As Variant
Dim HFlg As Boolean

Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim myStr, ra, rr
Search1 = InputBox("検索日(複数可)を入力" & vbNewLine & "（指定しない場合はキャンセル押下）", "条件入力")
Search2 = InputBox("依頼部署(複数可)を入力" & vbNewLine & "（指定しない場合はキャンセル押下）", "条件入力")
If myStr = "" Then
MsgBox "検索はキャンセルされました。", vbInformation
Cells.Select
Selection.EntireRow.Hidden = False
Range("A1").Select
Exit Sub

Set ws1 = Sheets("日報") '検索　シート
Set ws2 = Sheets("集計表") '貼付先シート
With ws1.Columns("Search1：A") '部分一致で検索（A列）
With ws1.Columns("Search1：B") '部分一致で検索（B列）
End With

Set rng = .Find(What:=myStr, LookAt:=xlPart, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox "ありません", vbCritical, myStr & "？　(￣～￣;)う～ん　　"
Else 'あったら
ra = rng.Address '最初に見つかったセルアドレス

Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng) '連続検索
Loop While rng.Address <> ra '繰り返し
Set rng = Nothing
End If
End With