【Excel VBA】コピー＆ペーストの自動化

質問

以下のエクセル表があり、同じ日付ごとのデータを自動的に別のシートに移したいです。
例えば、別のシートに、2004/1/1に書かれているデータのみを移す。（シート２参照）

それをVBAで書くにはどうすればいいでしょうか。
マクロの記録をするのではなく、この表の日付を増やしたり変えたりしても機能するようにコードを書きたいと思っております。

For LoopとIf thenを使い、A1セルがそれより下のセルの値と異なるまでコピーし続ける、、といった作業をすればよいのでしょうか。

全くの初心者で勉強中です。よろしくお願いいたします。

列行 A B
１ 2004/1/1 太郎
２ 2004/1/1 次郎
３ 2004/1/1 三郎
４ 2004/1/1 一郎
５ 2004/1/1 五郎
６ 2005/3/3 三郎
７ 2005/3/3 次郎
８ 2005/3/3 太郎
９ 2005/3/3 四朗
１０ 2006/2/2 次郎
１１ 2006/2/2 一郎
１２ 2006/2/2 太郎

シート２
2004/1/1
太郎
次郎
三郎
一郎
五郎

シート３
2005/3/3
三郎
次郎
太郎
四朗

シート４
2006/2/2
次郎
一郎
太郎

回答No.2

goota33

とりあえず下記のソースでご質問された内容の動作ができてる？ことを確認したので
試してみてください。

使うときの注意点として、
A列には日付、B列には名前を必ず入力することと、
一番左側のワークシート以外は全部削除してしまうので、
下記のプログラムを実行する前にSheet2やSheet3といったワークシートが
削除されてもいいか確認してください。

もし必要であればプログラムの解説もいたします。

Public Sub sub_SplitDate()
Dim i As Long, j As Long, k As Long
Dim lngBeforeDate As Long
Dim lngAfterDate As Long
Dim wbkActiveSheet As Worksheet
Dim rngInputData As Range
Dim r As Range
Dim lngLastRow As Long
Dim varInputArray As Variant

Set wbkActiveSheet = ActiveSheet
With Worksheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To lngLastRow
If i = lngLastRow Then Exit For

lngBeforeDate = DateValue(.Cells(i, 1).Value)
lngAfterDate = DateValue(.Cells(i + 1, 1).Value)

If lngBeforeDate = lngAfterDate Then

Else
j = j + 1

End If

Next i

j = j + 1
If Worksheets.Count > 1 Then
For i = 2 To Worksheets.Count
Application.DisplayAlerts = False
Worksheets(2).Delete
Application.DisplayAlerts = True

Next i

End If
For i = 1 To j
Worksheets.Add after:=Worksheets(Worksheets.Count)

Next i
wbkActiveSheet.Activate

j = 2
k = 1
For i = 1 To lngLastRow
If i = lngLastRow Then Exit For

' MsgBox Worksheets(1).Cells(i, 2).Value
lngBeforeDate = DateValue(.Cells(i, 1).Value)
lngAfterDate = DateValue(.Cells(i + 1, 1).Value)
If lngBeforeDate = lngAfterDate Then
With Worksheets(j)
If k = 1 And i = 1 Then
MsgBox Worksheets(1).Cells(i, 2).Value

.Cells(k, 1).Value = Worksheets(1).Cells(i, 1).Value
k = k + 1
.Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
k = k + 1

Else
.Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
k = k + 1

End If
End With
Else
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
j = j + 1
k = 1
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 1).Value
k = k + 1
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value

End If

Next i
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(lngLastRow, 2).Value

End With

End Sub

回答No.1

keithin

＞For LoopとIf thenを使い、A1セルがそれより下のセルの値と異なるまでコピー

セルを一つ一つ舐め回して書き写していくのは，まぁ一番「簡単そう」なのでそういうやり方を好むヒトもいますが，一番遅くて効率の悪い方法です。

幾つか，ご相談の言葉足らずで前提条件が不明な箇所があります。
●そもそもふつーは１行目にタイトル行，２行目から実データにしますが，ホントにご質問で例示されたようにいきなり一行目から実データを列記しているのですか。
●Ａ列の日付は，必ず昇順で既に並べ替えてあるのですか。それともホントは順不同のデータを処理したいのですか。
●いまは「1/1のデータを移す」と，あたかもリストに1/1があり3/3がある事が「既知の事実」であるかのように書かれていますが，ホントにやりたいのは「日付に該当するシートもマクロで作成する」ところからではないのですか。それともそこは判ってるので質問していない（回答不要）のですか。

準備：
ブックを開く
Sheet1にデータを用意する
ALT+F11を押す
挿入メニューから標準モジュールを挿入する
標準モジュールにマクロを記載する

作成例：
sub macro1()
　dim h as range
　for each h in worksheets("Sheet1").range("A1:A" & worksheets("Sheet1").range("A65536").end(xlup).row)
’シートを用意する
　if application.countif(worksheets("Sheet1").range("A1:A" & h.row), h.value) = 1 then
　　worksheets.add after:=worksheets(worksheets.count)
　　activesheet.name = format(h.value ,"yyyymmdd")
　　h.copy destination:=range("A1")
　end if

’データを転記する
　worksheets(format(h.value, "yyyymmdd")).range("A65536").end(xlup).offset(1).value = h.offset(0, 1).value
　next
end sub