エクセルVBA記録から月毎の抽出

質問

お世話になります、A３にナンバー、B３に日付、C３に曜日、D３に項目、E3に詳細、F3に金額が、ここからデータFirstRowとして入力されていきます。入力されたデータから月毎１２枚のシートに抽出していきたいのですが何方かご教示お願いします。できましたら年別も抽出出来たらうれしく思います。宜しくお願いします

回答No.5

kkkkkm · ベストアンサー

> そこで誠に勝手ではありますが各年月毎の構文をお願いしたいのですが・

以下でいけると思いますので試してみてください。シート名はxxxx年x月で作成するようにしています。データ元シートにデータのある年月分シートが作成されます。

Sub Example()
Dim c As Range
Dim i As Integer, LastRow As Long
Dim NewSheetName As String, MatchFlag As Boolean

Application.ScreenUpdating = False
NewSheetName = ""
With Sheets("データ元")
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
MatchFlag = False
If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then
NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月"
For i = 1 To Worksheets.Count
If Sheets(i).Name = NewSheetName Then
Sheets(i).Cells.ClearContents
MatchFlag = True
Exit For
End If
Next i
If MatchFlag = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = NewSheetName
End If
End If
LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
Sheets(NewSheetName).Columns("A:F").EntireColumn.AutoFit
'↑A列からF列まで自動幅調整してます
Next
.Activate
End With
Application.ScreenUpdating = True
MsgBox "終了しました", vbInformation
End Sub

お礼

感動しました！私もこのような構文が書けるように精進します。本当にありがとうございました。

回答No.7

kkkkkm

データは年月分がかたまっていない場合、こちらにしてください。年月分の順番はバラバラでも年月分がまたいでいても大丈夫です。
2016/2/5
2016/2/25
2016/3/6
2016/3/16
2015/10/18
2015/10/28
2016/3/26
2016/2/15
2016/4/5
2016/5/5
2016/4/15
2016/4/25
2016/5/15
2016/5/25
上記のような並びでも大丈夫です。上から出現した順に該当シートに転記していきますので同じ年月でも日が前後していた場合は、前後したまま転記されます。

前後したままで転記されると気持ちが悪いので日付を昇順で並び替えたいとかありましたら、A案かB案かのどちらかを選択してコメントを解除してください。

Sub Example()
Dim c As Range
Dim i As Integer, j As Integer, LastRow As Long
Dim NewSheetName As String, AddSheetName As String, TempSheetName As String
Dim DateData As Variant, MatchFlag As Boolean, buf As Variant

Application.ScreenUpdating = False
With Sheets("データ元")

' 並び替えA案　データ元シートを並び替え
' .Range(.Cells(3, "A"), Cells(Rows.Count, "F").End(xlUp)) _
' .Sort Key1:=.Cells(3, "B"), order1:=xlAscending
' 上の2行をコメント解除すると日付をキーとしてデータ元を並び替えします。
' コピーのシートで並び替える場合は不用です。

' 並び替えB案　データ元のシートのコピーシートを作成して並び替えしそのデータを操作対象とします
' ↓ここから下のここまで
' .Copy After:=Worksheets("データ元")
' TempSheetName = ActiveSheet.Name
' With Sheets(TempSheetName)
' .Range(.Cells(3, "A"), Cells(Rows.Count, "F").End(xlUp)) _
' .Sort Key1:=.Cells(3, "B"), order1:=xlAscending '
' ↑ここまで コメント解除するデータ元シートのコピーとコピーしたシートの並び替え
' データ元シートを並び替えた場合は不用です。
'
DateData = .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))

'並びがバラバラだったときにシートが年月順に作られないのでシート作成用日付データを並び替えています。
' A案もしくはB案でデータ自体を並び替えした場合はここは不用です。
For i = LBound(DateData) To UBound(DateData)
For j = UBound(DateData) To i Step -1
If DateData(i, 1) > DateData(j, 1) Then
buf = DateData(i, 1)
DateData(i, 1) = DateData(j, 1)
DateData(j, 1) = buf
End If
Next j
Next i
'日付データ並び替えここまで

For i = LBound(DateData) To UBound(DateData)
MatchFlag = False
NewSheetName = Year(DateData(i, 1)) & "年" & Month(DateData(i, 1)) & "月"
For j = 1 To Worksheets.Count
If Sheets(j).Name = NewSheetName Then
Sheets(j).Cells.ClearContents
MatchFlag = True
Exit For
End If
Next j
If MatchFlag = False Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = NewSheetName
End If
Next i
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
AddSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月"
LastRow = Sheets(AddSheetName).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(AddSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
Sheets(AddSheetName).Columns("A:F").EntireColumn.AutoFit
'↑A列からF列まで自動幅調整してます
Next

' 並び替えB案(データ元シートのコピー)を採用した場合は下の4行をコメント解除
' Application.DisplayAlerts = False
' .Delete
' Application.DisplayAlerts = True
' End With

.Activate
End With
Application.ScreenUpdating = True
MsgBox "終了しました", vbInformation
End Sub

回答No.6

kkkkkm

No5の追加です。

データは年月分がかたまっているという前提で作成しています。
以下のような感じです。

2015/5/21
2015/5/31
2015/6/10
2015/6/20
2015/7/20
2015/7/30
とか
2015/5/21
2015/5/31
2015/7/20
2015/7/30
2015/6/10
2015/6/20
などのような感じです。年月分がかたまりであれば順番は問いません。

以下のように年月分が他の年月をまたぐ(5月10日が6月分の後にある)ようだとだめですので考え直します。
2015/5/21
2015/5/31
2015/6/10
2015/6/20
2015/5/10
2015/7/20
2015/7/30

回答No.4

kkkkkm

No3の追加です。

現状の月毎は実行した年になってますので、今の２００６年から２００８年までだと月毎が転記されませんから
If Year(c.Value2) = Year(Date) Then
を実際に一年分データがある年、たとえば2006年でしたら
If Year(c.Value2) = 2006 Then
に変更して試してください。

また、データ元シートのデータに
YearSheetName = Array("２００６年", "２００７年", "２００８年")
以外の年データがあるとその年のシートが存在しても最後の方でエラーになります。年毎の転記がそれでいいのかどうかいまいち不明だったのでそのあたりは仮の状態になってます。

補足

有難うございました、何とか完成しました。しかしながら１２か月設定がマクロ内で操作しないといけないので使用に際しては不便だと感じました。
そこで誠に勝手ではありますが各年月毎の構文をお願いしたいのですが・・・本当にすみませんこれからは１ブック５年単位で入力して行こうと思います。宜しくお願いします。

回答No.3

kkkkkm

> sheets(MonthSheetName(1).Cells.ClearContentsnに黄色が出てエラーとなります。

書き忘れてましたコードは標準モジュールに記載してください。標準モジュールに記載してエラーになる場合

> Sheet1にデータ元、
With Sheets("シート６") '実際のシート名に変更
ここのシート6をデータ元に
> Sheet２～１３は１～１２のシート名、
MonthSheetName = Array("Sheet1", "Sheet2", "Sheet3・・・
ここのSheet1から１～１２のシート名に
> Sheet1４～１６は２００６年２００７年２００８年のシート名を作りました
YearSheetName = Array("2015年", "2016年", "2017年")
が
YearSheetName = Array("２００６年", "２００７年", "２００８年")
に
FirstYear = 2015
が
FirstYear = 2006
になっているか確認してください。

また、月毎は実行した年(今年なら2016年)にたいしてだけ行ってます。各年月毎(2006年月毎2007年月毎・・・)にしたい場合は違う方法になりますのでお知らせください。各年月別だとシートはVBAで作成したほうがいいですね。ただ、各年月毎になるとシートの数がかなりになりますけど・・・。

現状でも年別はVBAでシートを作成したほうがいいかもしれません。とりあえず、動作の確認(取り出し方の確認)ということでNo1のコードを試してみてください。

お礼

有難うございます、上記書き間違えました、各年月毎でお願いします。

補足

お世話になります、書いていただいた通り修正して実行しましたが今度はLastRow = Sheets(YearSheetName(j)).Cells(Rows.Count, "A").End(xlUp).Rowに黄色が出てエラーとなりました。
元々私の理解不足からなのですがどこが悪いのでしょうか？私に無理のようでしたら年別なしでも良いのですが！宜しくお願いします。

回答No.2

ushi2015

こんにちは
年、月の列を追加して、ピボットテーブルを作成するのが簡単でいいのでは？
データ範囲は、適当な名前で
=INDIRECT("Sheet1!$A$3:$H"&COUNTA(Sheet1!$A$3:$A$100)+2)
のように設定しておいてピボットテーブルのデータソースに指定しておけば
いいと思います。
どうしてもシートを分けたければピボットテーブルを作成したシートを11枚
コピーして、12枚のシートでそれぞれ月の指定を替えればいいですし、元データ
が更新された場合もピボットを更新するだけです。

お礼

ご指摘有難うございます、この件ではピボットを使わないVBAを目指しています。有難うございました。

回答No.1

kkkkkm

このような動作でしょうか。

Sub Example()
Dim c As Range
Dim i As Integer, j As Integer, FirstYear As Integer, LastRow As Long
Dim MonthSheetName As Variant, YearSheetName As Variant

MonthSheetName = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9", "Sheet10", "Sheet11", "Sheet12")
'実際のシート名に変更　左から1月、2月、3月・・・が転記される
YearSheetName = Array("2015年", "2016年", "2017年")
'実際のシート名に変更　左から1年毎にする
FirstYear = 2015 '上記で設定した年のシートの最初の年を数値で記載
For i = LBound(MonthSheetName) To UBound(MonthSheetName)
Sheets(MonthSheetName(i)).Cells.ClearContents
Next
For i = LBound(YearSheetName) To UBound(YearSheetName)
Sheets(YearSheetName(i)).Cells.ClearContents
Next
With Sheets("シート６") '実際のシート名に変更
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
If Year(c.Value2) = Year(Date) Then
i = Month(c.Value2) - 1
LastRow = Sheets(MonthSheetName(i)).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(MonthSheetName(i)).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
End If
j = Year(c.Value2) - FirstYear
LastRow = Sheets(YearSheetName(j)).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(YearSheetName(j)).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value
Next
End With
End Sub

補足

いつも有難うございます。
sheets(MonthSheetName(1).Cells.ClearContentsnに黄色が出てエラーとなります。（Sheet1にデータ元、Sheet２～１３は１～１２のシート名、Sheet1４～１６は２００６年２００７年２００８年のシート名を作りました）うまくいきません宜しくお願いします。