[[20130219103828]]　『日付ごとにセルを結合または日付を一行だけ表示』（ゆき）　ページの最後に飛ぶ

『日付ごとにセルを結合または日付を一行だけ表示』（ゆき）

 Excel2010で、ユーザーフォームから出荷予定リストを作っています。

 元のシートに

 　　　　A　　　　　B　　　　C　　　　　D　　　　
 1　　全物件リスト
 2　　出荷日　　 　納品日　　管理番号　　物件
 3　　2013/2/1　　2013/2/2　 AA1302-01　ABCビル
 4　　2013/2/4　　2013/2/5　 AA1302-02　いろは公園
 5　　2013/2/12　 2013/2/12　AB1302-01　ABCビル

 このような感じでV列までデータが入っています。

 この中から、「2013/2/19～2013/2/22」のように期間を指定して、出荷予定一覧を作っています。

 やり方はTextBox1に期間の開始日、TextBox2に期間の終了日を入れ、「出荷予定_雛形2」
 というシートをコピーして下記のようなレイアウトのシートを作ります。

 　　　A　　　　　　B　　　　　C　　　　　　　D　　　　E　　　　F　　　　G　　　　　H
 1　出荷予定一覧
 2　出荷日　　　管理番号　　　物件　　　　　品種　　　数量　　担当　　配送方法　　備考
 3　2013/2/19　 AB1302-10　ホテル○○　　　　AA　　　　10　　 田中　　自社便
 4　2013/2/20　 CC1302-01　東京AAビル　　　　CC　　　　 3　　 鈴木　　佐川急便　　2個口
 5　2013/2/20　 DD1302-03　○○社新築工事　　AD　　　　 1　　 鈴木　　福山通運
 6　2013/2/20　 BB1302-02　○○社新築工事　　BB　　　　 1　　 鈴木　　福山通運　DD1302-03と同梱
 7　2013/2/21　 AB1302-09　朝日公園　　　　　AB　　　　20　　 田中　　チャーター
 8　2013/2/21　 CC1302-02　○○大学　　　　　CC　　　　14　　 田中　　自社便

 上記のようになったシートに、格子罫線を引いて一覧表として印刷しています。
 やりたいのは、現在は出荷予定日が同じものがずらっと並んでいるので、同じ出荷日で
 ひとかたまりにするために
 ・A列の同じ出荷予定日のセルを結合して一つのセルにする
 または
 ・A列で、同じ出荷予定日の日付は一行しか表示せず、

 4　2013/2/20　 CC1302-01　東京AAビル　　　　CC　　　　 3　　 鈴木　　佐川急便　　2個口
 5　            DD1302-03　○○社新築工事　　AD　　　　 1　　 鈴木　　福山通運
 6　            BB1302-02　○○社新築工事　　BB　　　　 1　　 鈴木　　福山通運　DD1302-03と同梱

 このようにして4行目・5行目の下線はひかない

 このどちらかで、「この塊が出荷日が同じもの」と分かりやすくしたいのですが、どのようにすればよいか行き詰りました。

 今、元のデータシートから該当データを抜き出し、雛形をコピーしたシートにデータを羅列、
 日付と物件でソートしたのが下記のコードです。

 Private Sub CommandButton1_Click()

 Dim i As Long
 Dim j As Long
 Dim z As Long
 Dim lRow As Long
 Dim sDate As Variant
 Dim eDate As Variant
 Dim myRow As Long
 Dim cnt As Long
 Dim shName As String
 Dim bName As String
 Dim DataCnt As Long

    If IsDate(TextBox1.Value) Then
        sDate = CDate(TextBox1.Value)
    Else
        MsgBox "正しい日付を入力してください"
        Exit Sub
    End If

     If IsDate(TextBox2.Value) Then
        eDate = CDate(TextBox2.Value)
    Else
        MsgBox "正しい日付を入力してください"
        Exit Sub
    End If

    Set ws1 = ThisWorkbook.Worksheets("全物件データ")
    z = ws1.Range("C" & ws1.Rows.Count).End(xlUp).Row

    DataCnt = 0
    cnt = 1
    bName = "出荷予定_" & Format(sDate, "mmdd") & "_" & Format(eDate, "mmdd")
    ThisWorkbook.Sheets("出荷予定_雛形2").Copy After:=Sheets(Sheets.Count)

    shName = bName

    Do
        If Not IsObject(Evaluate("'" & shName & "'!A1")) Then Exit Do
        cnt = cnt + 1
        shName = bName & "(" & cnt & ")"
    Loop

    ActiveSheet.Name = shName
    Set lsh = ThisWorkbook.Sheets(Sheets.Count)

    For i = 3 To z

        lRow = lsh.Range("B" & lsh.Rows.Count).End(xlUp).Row

        j = lRow + 1

        If ws1.Cells(i, 1).Value >= sDate And ws1.Cells(i, 1).Value <= eDate Then
            lsh.Cells(j, 1).Value = ws1.Cells(i, 1).Value
            lsh.Cells(j, 2).Value = ws1.Cells(i, 3).Value
            lsh.Cells(j, 3).Value = ws1.Cells(i, 4).Value
            lsh.Cells(j, 4).Value = ws1.Cells(i, 7).Value
            lsh.Cells(j, 5).Value = ws1.Cells(i, 8).Value
            lsh.Cells(j, 6).Value = ws1.Cells(i, 10).Value
            lsh.Cells(j, 7).Value = ws1.Cells(i, 11).Value
            lsh.Cells(j, 8).Value = ws1.Cells(i, 22).Value

            DataCnt = DataCnt + 1

        End If
    Next i

    myRow = lsh.Range("B" & lsh.Rows.Count).End(xlUp).Row

    lsh.Range("A3:H" & myRow) _
        .Sort key1:=lsh.Cells(3, 1), order1:=xlAscending, _
              key2:=lsh.Cells(3, 3), order2:=xlAscending

    With lsh.Range("A2:H" & myRow).Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With

 End Sub

 よろしくお願いいたします。

 日付の後に物件名でソートしているので、必ず日付順に並んでいるわけではないんですよね？
 結合は好きじゃないので、とりあえず後者の案でサンプルを書いてみました。
Sub sample()
Dim s As Long, a As Range
s = 3
For Each a In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
    If a.Value <> a.Offset(1, 0).Value Then
       a.Resize(, 8).Borders(xlEdgeBottom).LineStyle = xlContinuous
       If a.Row <> s Then
          a.Offset(s - a.Row + 1).Resize(a.Row - s).ClearContents
       End If
       s = a.Row + 1
    End If
Next a
End Sub　
(Jera)

 1) 実際にMergeする

 Sub DoMerge()
    Dim i As Long, myDate, temp
    Application.DisplayAlerts = False
    With Range("a1").CurrentRegion
        .Offset(1).Resize(.Rows.Count - 1).Borders.Weight = 2
        temp = 3: myDate = .Cells(3, 1).Value
        For i = 3 To .Rows.Count + 1
            If myDate <> .Cells(i, 1).Value Then
                .Rows(temp & ":" & i - 1).Columns(1).Merge
                myDate = .Cells(i, 1).Value
                temp = i
            End If
        Next
    End With
    Application.DisplayAlerts = True
End Sub

 2) 罫線だけ

 Sub BordersOnly()
    Dim i As Long, myDate, temp
    With Range("a1").CurrentRegion
        .Offset(1).Resize(.Rows.Count - 1).Borders.Weight = 2
        temp = 3: myDate = .Cells(3, 1).Value
        For i = 3 To .Rows.Count + 1
            If myDate <> .Cells(i, 1).Value Then
                With .Rows(temp & ":" & i - 1).Columns(1)
                    .Borders(12).LineStyle = xlNone
                    .ClearContents
                    .Cells(1).Value = myDate
                End With
                myDate = .Cells(i, 1).Value
                temp = i
            End If
        Next
    End With
End Sub
(seiya)

 (Jera)様、すみません、説明不足でした（汗）

  ＞このようにして4行目・5行目の下線はひかない
 これはA列の4行目・5行目だけ下線をひかない、というつもりでした…言葉足らずですみません…

 ＞必ず日付順に並んでいるわけではないんですよね
 はい、そうです。

 (seiya)様
 ありがとうございます。
 どちらの案でもうまくいきました！

 （ゆき）

コメント返信：

[ 一覧(最新更新順) ]

[[20130219103828]] 『日付ごとにセルを結合または日付を一行だけ表示』（ゆき） ページの最後に飛ぶ

[[20130219103828]]　『日付ごとにセルを結合または日付を一行だけ表示』（ゆき）　ページの最後に飛ぶ