【VBA】日付ごとのデータで列を作りたい

Question

やりたいこと

①元データのA列を2行目から順番に最後までチェックし、重複しているものは無視、していないものは別シートのA1→B1→C1と1行目に入れる
②データ貼り付け先の1行目とコピー元のA列を参照し、一致するものはそのB列のデータをコピー先の一致した列に上から順番に貼り付ける
※日付ごとの列にしたい

現状

①曜日が入っていると上手く反映されないので消しています

        Columns("A:A").Select

        Selection.Replace What:="(金)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(木)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(土)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(日)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(月)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(火)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        Selection.Replace What:="(水)", Replacement:="　", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

②現状は時間のところに日付をコピペしてB列ごとデータをコピペしているため、日付ごとに対応できてないです

    '受付履歴の時間を"データ"シートに保存しておく
    Range("A2").Copy
    Range("B1").Select
    ActiveSheet.Paste
    
    Range(Range("B1"), Cells(Rows.count, 2).End(xlUp)).Copy ThisWorkbook.Sheets("データ").Cells(1, Columns.count).End(xlToLeft).Offset(, 1)
    
    Next  'ループおわり

困っていること

下のコードでA2以降の重複しない日付を取れるかなと思うのですが、
A列じゃなくてB列から取りたい時はどこをいじればいいのか分からないです(´・ω・｀)
また、取ったデータを別シートに貼り付けたい時はどのようにしたら良いのでしょうか…

    Dim A As New Collection, i As Long
    On Error Resume Next
    For r = 2 To Cells(Rows.count, 1).End(xlUp).Row
        A.Add Cells(i, 1), Cells(i, 1)
    Next i

Comments

[firstlast]

VBAを使えば繰り返し処理や条件判断や代入ができますが、質問内容には繰り返しや条件判断の部分が欠落しています。
そういう観点で頭を整理したほうがいいと思います。
そうすれば、質問内容も具体的にかけるようになると思います。

[Jonny_dayo]

回答ありがとうございます！
そうですね、すみません混乱したふわっとした質問となっておりました…

①元データのA列を2行目から順番に最後までチェックし、重複しているものは無視、していないものは別シートのA1→B1→C1と1行目に入れていく

②データ貼り付け先の1行目とコピー元のA列を参照し、一致するものはそのB列のデータをコピー先の一致した列に上から順番に貼り付けていく。

やりたいことを具体化するとこんな感じになります！

[firstlast]

やりたいことができないのはどんな障壁があるからでしょうか？

[hatena19]

日付は降順で並んでいるのですか。画像ではそうなってますが、実際のデータも最後まで降順ですか。
日付毎の時刻の重複は排除しなくていいですか。

[Jonny_dayo]

＞日付は降順で並んでいるのですか。画像ではそうなってますが、実際のデータも最後まで降順ですか。
はい、実際のデータもこの通りです！

[hatena19]

日付毎の時刻の重複は排除しなくていいですか。

[Jonny_dayo]

直前に以下のコードで時間の重複削除は実行しますので、大丈夫です！

Dim A As Long
With Range("C9")
For A = .CurrentRegion.Rows.count To 1 Step -1
If .Offset(A, 0) = .Offset(A - 1, 0) Then .Offset(A, 0).EntireRow.Delete
Next A
End With

※実際のデータはC9以下に時間が来るためこのようなコードになっています。

Answer 1

私が作るとこんな感じになります。
※日付の書式が少し違いますが、取り敢えず無視してください。

Public Sub xxx()

    Dim sht As Excel.Worksheet
    
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    Dim i As Integer
    Dim save_date As Date
    Dim x As Integer
    i = 1                                                               '左表（コピー元）の行番号
    x = 4                                                               '右表（コピー先）の列番号
    
    save_date = DateSerial(2019, 12, 31)            '左表の1行目で日付をブレイクさせるため便宜的に任意の日付を代入する。
    Do Until sht.Cells(i, 1) = ""                       'データがなくなったらループを抜ける。
        temp_date = sht.Cells(i, 1)                     '左表のカレント行(i行目)の日付を格納する。
        If temp_date <> save_date Then          '左表の日付がブレイクしたら
            If i > 1 Then x = x + 1                       '     2行目以降でブレイクしたときだけ、右表のコピー先の列を右に１つずらす。
            sht.Cells(1, x) = temp_date                '    左表の日付を右表の列見出しにコピーする。
            y = 2                                                    '      時刻のコピー先を2行目にする。
        End If
        
        sht.Cells(y, x) = sht.Cells(i, 2)               '左表の時刻(i行2列)を右表(y行x列)にコピーする。
        y = y + 1                                                   '右表のコピー先の行番号をプラス１する。
        
        save_date = sht.Cells(i, 1)                     'ブレイク判定用
        i = i + 1                                                   '左の表のコピー元の行番号をプラス１する。
    Loop



End Sub

Comments

[Jonny_dayo]

回答ありがとうございます！
むむむ、自分用に当てはめてみたのですが、何も動かないです…

Dim sht As Excel.Worksheet

Set sht = ThisWorkbook.Worksheets("コピー元")

Dim b As Integer
Dim save_date As Date
Dim temp_date As Date　　'宣言無かったので追記
Dim x As Integer
Dim y As Integer　 　　　　'宣言無かったので追記
b = 9
x = 1

save_date = DateSerial(2019, 12, 31)
Do Until sht.Cells(b, 1) = ""
temp_date = sht.Cells(b, 1)
If temp_date <> save_date Then
If b > 1 Then x = x + 1
sht.Cells(1, x) = temp_date
y = 2
End If

sht.Cells(y, x) = sht.Cells(b, 2)
y = y + 1

save_date = sht.Cells(b, 1)
b = b + 1
Loop

・loopでのiは他で既に使ってしまったので、bとしました。
・コピー先のシートの指定はどこでしたら良いのでしょうか？？
・色々他の動きをさせている途中で行いたいのですが、その際はPublic Sub xxx()は取っても大丈夫でしょうか…？

[firstlast]

xxxは仮の名前なので、無視してください。
私が提示したソースコードで注目して欲しいのは、キーブレイクを判定している点と、シートの参照(Cells)、セルの参照と代入(Cells)、条件判断(IF)、繰り返し処理(Loop)です。

コピー先のシートの指定は、
Set sht2 = ThisWorkbook.Worksheets("コピー先")
でできます。そのシートのセルに値をコピーするときはsht2.Cells(m, n) = [値] のようにします。

＜補足＞
私が提示したソースコードは、
キーブレイクを使っているので、左表がキー項目（日付）でソートされている必要があります。あと、重複を排除する処理は含まれていません。
質問内容の「こまっていること」にあるようにコレクションにデータを入れて重複を排除したあとに、そのコレクションの内容をコピー先に代入していく必要があります。

Answer 2

出力シートへ逐次データを追記して行くように変えました。

Option Explicit

Public Sub 並べ替え()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Set sh1 = Worksheets("データ")
    Set sh2 = Worksheets("作業")
    Set sh3 = Worksheets("出力")
    Dim wrow As Long
    Dim maxrow As Long
    Dim maxrow2 As Long
    Dim maxcol2 As Long
    Dim maxcol3 As Long
    Dim wrow2 As Long
    Dim wcol2 As Long
    Dim wcol3 As Long
    Dim prevDate As String
    Dim prevTime As Variant
    Dim wdate As String
    Dim wtime As Variant
    sh2.Cells.ClearContents
    maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'データシート 1列目の最終行を求める
    prevDate = ""
    wcol2 = 0
    '作業シートへ転記
    For wrow = 2 To maxrow
        wdate = sh1.Cells(wrow, 1).Value
        wtime = sh1.Cells(wrow, 2).Value
        If wdate <> prevDate Then
            wcol2 = wcol2 + 1
            sh2.Cells(1, wcol2) = Left(wdate, 10)
            wrow2 = 1
            prevTime = -1
        End If
        If wtime <> prevTime Then
            wrow2 = wrow2 + 1
            sh2.Cells(wrow2, wcol2) = wtime
        End If
        prevDate = wdate
        prevTime = wtime
    Next
    '出力シートへ転記
    maxcol2 = sh2.Cells(1, Columns.Count).End(xlToLeft).Column   '作業シート　1行目の最終列を求める
    maxcol3 = sh3.Cells(1, Columns.Count).End(xlToLeft).Column   '出力シート　1行目の最終列を求める
    If sh3.Cells(1, maxcol3).Value = "" Then                     '最初は１列から出力する為の調整
        maxcol3 = maxcol3 - 1
    End If
    For wcol2 = 1 To maxcol2
        maxrow2 = sh2.Cells(Rows.Count, wcol2).End(xlUp).Row     '作業シート 処理列の最終行を求める
        wcol3 = maxcol2 - wcol2 + maxcol3 + 1                    '出力シートの出力列を算出
        sh3.Range(sh3.Cells(1, wcol3), sh3.Cells(maxrow2, wcol3)).Value = sh2.Range(sh2.Cells(1, wcol2), sh2.Cells(maxrow2, wcol2)).Value
    Next
    MsgBox ("完了")
End Sub

Answer 3

元データのファイルがあれば、確実な結果が保障できますが、
それがないので推定で書きます。
（元データのファイルを　https://firestorage.jp/　等の共有サイトにアップできるならアップしてください。）

元データのシート：データ
作業データのシート：作業
出力先のシート：出力
としています。

Option Explicit

Public Sub 並べ替え()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Set sh1 = Worksheets("データ")
    Set sh2 = Worksheets("作業")
    Set sh3 = Worksheets("出力")
    Dim wrow As Long
    Dim maxrow As Long
    Dim maxrow2 As Long
    Dim maxcol2 As Long
    Dim wrow2 As Long
    Dim wcol2 As Long
    Dim wcol3 As Long
    Dim prevDate As String
    Dim prevTime As Variant
    Dim wdate As String
    Dim wtime As Variant
    sh2.Cells.ClearContents
    sh3.Cells.ClearContents
    maxrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'データシート 1列目の最終行を求める
    prevDate = ""
    wcol2 = 0
    '作業シートへ転記
    For wrow = 2 To maxrow
        wdate = sh1.Cells(wrow, 1).Value
        wtime = sh1.Cells(wrow, 2).Value
        If wdate <> prevDate Then
            wcol2 = wcol2 + 1
            sh2.Cells(1, wcol2) = Left(wdate, 10)
            wrow2 = 1
            prevTime = -1
        End If
        If wtime <> prevTime Then
            wrow2 = wrow2 + 1
            sh2.Cells(wrow2, wcol2) = wtime
        End If
        prevDate = wdate
        prevTime = wtime
    Next
    '出力シートへ転記
    maxcol2 = sh2.Cells(1, Columns.Count).End(xlToLeft).Column   '作業シート　1行目の最終列を求める
    For wcol3 = 1 To maxcol2
        maxrow2 = sh2.Cells(Rows.Count, wcol3).End(xlUp).Row     '作業シート 処理列の最終行を求める
        sh3.Range(sh3.Cells(1, maxcol2 - wcol3 + 1), sh3.Cells(maxrow2, maxcol2 - wcol3 + 1)).Value = _
        sh2.Range(sh2.Cells(1, wcol3), sh2.Cells(maxrow2, wcol3)).Value
    Next
    MsgBox ("完了")
End Sub

実行前のデータのシート及び実行後の出力のシートは、以下の通りです。

「出力」シートの１行目の書式設定は日付、2行目以降の書式設定は時刻を設定してください。
（設定値が判らなければその旨補足してください）

Comments

[Jonny_dayo]

うわあああああああああああああ！！！
できたああああああ！！！！！！
ありがとうございます！！ありがとうございます！！

他にも回答してくださった皆様本当にありがとうございました！！

[Jonny_dayo]

ベストアンサーに選んだ後からで申し訳ないのですが、、
確認していたところ、シートを読み込むたびにそのデータのみが反映されている気がするのですが、
読み込むたびに「出力」シートの右にどんどん追記されていくようなスタイルにしていくことって可能なのでしょうか？

[tatsu99]

そのような場合は、その旨を質問欄に最初に書くようにしましょう。データを追記する旨が書かれていないので、出力シートを最初にクリアしています。修正版を別回答欄に書きましたので、そちらを参照してください。

[Jonny_dayo]

お手数おかけしました！！！
ありがとうございました(´;ω;｀)！！

Answer 4

ソート機能を使ったやり方で実装してみました。
ソートを使えば貼り付けたい順に並べられるので判定する手間が減るからです。
元のデータを破壊しないようにコピーしてからソートしています。

Option Explicit

Public Sub peast()
    'ダイアログ無視
    Application.DisplayAlerts = False

    'データシートをコピーしてworkシートを作成する
    Worksheets("Sheet1").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "work"
    
    '最下行取得
    Dim iMaxRows As Integer
    iMaxRows = Cells(Rows.Count, 2).End(xlUp).Row
    
    '日付昇順でソート
    With Range(Cells(2, 1), Cells(iMaxRows, 2))
        .Sort Key1:=.Cells(2, 1), Order1:=xlAscending
    End With
    
    '範囲開始行数
    Dim rbRow As Integer
    rbRow = 2
    
    '列インデックス
    Dim columnIdx As Integer
    columnIdx = 1
    
    Dim i As Integer
    For i = 2 To iMaxRows
        '次行の日付の値が異なる場合
        If Cells(i, 1) <> Cells(i + 1, 1) Then
            With Worksheets("Sheet2")
                '日付の書式を設定して貼付
                .Cells(1, columnIdx).NumberFormatLocal = "yyyy/mm/dd(aaa)"
                .Cells(1, columnIdx).Value = Cells(rbRow, 1).Value
                '時間の書式を設定して範囲貼付
                .Range(.Cells(2, columnIdx), .Cells(2 + (i - rbRow), columnIdx)).NumberFormatLocal = "hh:mm:ss"
                .Range(.Cells(2, columnIdx), .Cells(2 + (i - rbRow), columnIdx)).Value = Range(Cells(rbRow, 2), Cells(i, 2)).Value
            End With
            '範囲開始行数に現在行を設定
            rbRow = i + 1
            '列インデックスをインクリメント
            columnIdx = columnIdx + 1
        End If
    Next i
    
    'workシートを削除する
    Sheets("work").Delete
    
    '列幅の自動調節
    Worksheets("Sheet2").Activate
    Range(Columns(1), Columns(columnIdx)).Columns.AutoFit
    
    'ダイアログ設定を戻す
    Application.DisplayAlerts = True
End Sub

Answer 5

Sub test()
    Dim rngData As Range
    Dim r As Range
    Dim myColl As New Collection
    Dim i As Long
    Dim rngTop As Range

    Set rngData = ActiveSheet.Range("A1").CurrentRegion.Offset(1)
    With rngData.Cells(1, 1)
        myColl.Add .Value, .Text
        Set rngTop = .Offset(, 1)
    End With

    For Each r In rngData.Row
        i = myColl.Count
        On Error Resume Next
        myColl.Add r.Cells(1).Value, r.Cells(1).Text
        On Error GoTo 0
        If i < myColl.Count Then
            With ActiveSheet.Range("E2")
                Application.Range(rngTop, r.Cells(0, 2)).Copy .Cells(1, mycol.Count)
                .Cells(0, 1).Value = myColl(myColl.Count - 1).Value
            End With
            set rngtop = r.cells(1,2)
        End If
    Next
End Sub

慌てて書いたら不細工になってしまった＞＜
時間が無いので、動作確認してません。
うまくいってないかも＾＾；
Collectionで重複の排除をされようとしているようなので、
それを使ってみました。
エクセル的にはもっと簡単に書けると思うけど。。。。
興味があればいってくれれば、サンプル書きます。
参考になれば。

---

小計機能でキーブレークの箇所に小計行を挿入し、
ジャンプ機能で分かれたデータを特定し、
集まり毎に転記するサンプル

Sub test()
    Dim Rng As Range
    Dim a As Range
    Dim i As Long

    'キーブレーク箇所に小計行挿入
    With Worksheets(1).Cells(1)
        .Subtotal GroupBy:=1, Function:=xlCount, TotalList:=2
        With .CurrentRegion
            Set Rng = Intersect(.Columns(2), .Offset(1))
        End With
    End With

    'キー毎（小計行は数式が入っているので定数のセルだけに特定）にコピペ
    For Each a In Rng.SpecialCells(xlCellTypeConstants).Areas
        i = i + 1
        With Worksheets(2).Cells(1)
            a.Copy .Cells(2, i)
            .Cells(1, i).Value = a.Cells(1, 0).Value
        End With
    Next
    
    '小計行削除
    Rng.CurrentRegion.RemoveSubtotal
End Sub

必要ならば並び替えも行ってください。
列方向の並び替えもエクセルでできる（はず。）。
個人的にはこっちの方が、考えるのが気楽かな。。。

Comments

[Jonny_dayo]

回答ありがとうございます！
For Eachは、コレクションオブジェクトまたは配列のみ繰り返しを実行します。
というメッセージが.Rowのところに出て固まってしまいました(´;ω;｀)
もっと簡単に書けるのが気になるので、お手数ですがサンプル見せてもらうことは可能でしょうか？

[mattuwan]

あああ、失敗＞＜

Collectionなので、
Row　→　Rows
ですね。意味解ります？

簡単にというか、エクセルの機能を一部流用して処理できます。
つまり人が書いたプログラムを使うので、
見た目の行数が減るかなぁ。。。というイメージです。

なのでVB的なロジックとは違う、エクセル的な発想が必要になります。
サンプルは暇を見て。。。

[mattuwan]

あ、あと、サンプルデータは画像ではなく、
テキストで貼り付けていただけると、
コピペが出来て回答側が動作確認しやすいかなと思います。
ここのサイトでどうやったら、簡単に体裁を整えられるか、よくわかってないですが＾＾；