1150476019

2022/7/2 0:55

22回答

Excel2019 vba で他部署から送られてくる日程表を画像の日程リストのように氏名、始め、終わりの項目に分けて出力したいのですがうまくいきません。ご教示お願いします。

Excel2019 vba で他部署から送られてくる日程表を画像の日程リストのように氏名、始め、終わりの項目に分けて出力したいのですがうまくいきません。ご教示お願いします。 Excel内には次の2つのワークシートがあります。「日程表」「日程リスト」。 日程表は他部署から送られてくるもので、2行目に日付※、次の行（9、13、17、22、26、31、35、39、43）に顧客名が記載してあります。この情報を同一ブック内の日程リストへ出力したいです。例えば、・氏名：青木さや、始め：2、終わり3、・氏名：那覇たみこ、始め：11、終わり13※基本的には日程表の各氏名欄は結合されており始めは結合の最初、終わりは結合の最後です。月の始めと月末は結合されていないものもありますので、そこは次のように出力したいです。・氏名：片山太一、始め：空欄、終わり1、・氏名：佐藤太郎、始め：31、終わり：空欄 ※カレンダーと同様に31日終わりもあれば、28日終わりもあります。必ず、月末の後（画像では31日の右側）には次月の項目があります。 お手数お掛けしますが、よろしくお願い致します。

画像

Visual Basic | Visual Basic・116閲覧・xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0
kky********

2022/7/2 6:31

一例です。 Sub test() Dim sh As Worksheet Dim cmax As Long, c As Long Dim r1 As Long, r2 As Long Application.ScreenUpdating = False Set sh = Worksheets("日程リスト") r2 = 1 With Worksheets("日程表") cmax = .Cells(2, Columns.Count).End(xlToLeft).Column For c = 3 To cmax For r1 = 9 To .Cells(Rows.Count, c).End(xlUp).Row If .Cells(r1, c).Value <> "" Then r2 = r2 + 1 sh.Cells(r2, 1).Value = .Cells(r1, c).Value If c = 3 And .Cells(r1, c).Merge = False Then sh.Cells(r2, 3).Value = .Cells(2, c).Value ElseIf c = cmax And .Cells(r1, c).Merge = False Then sh.Cells(r2, 2).Value = .Cells(2, c).Value Else sh.Cells(r2, 2).Value = .Cells(2, c).Value sh.Cells(r2, 3).Value = .Cells(2, c + .Cells(r1, c).MergeArea.Columns.Count - 1).Value End If End If Next r1 Next c End With Application.ScreenUpdating = True End Sub

1150476019

質問者2022/7/2 10:05

回答ありがとうございます。 下記についてご教示願います。 教えていただいたコードを実行しましたが、例えば13行目のCD列が結合して顧客名が入力されている場合そちらも結合されていないセルと同様に終わりの欄のみ出力されてしまいます。下記コードのIf c = 3 And .Cells(r1, c).Merge = False Then で日程表3列目の値が結合でない場合の条件分岐を記載していただてますが、月の始めが結合セルの場合に始めと終わりを両方とも出力するにはどのようなコードを追記すれば良いでしょうか。 回答よろしくお願い致します。

ThanksImg質問者からのお礼コメント

ありがとうございました。

お礼日時：7/2 22:31

その他の回答（1件）

0
PSX

2022/7/2 13:37

Sub a() '名前入力範囲において名前以外は文字が入力されてないこと '１日が３列目から始めっていることが前提です。 '可読性はあまりよくないかもです。 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim c As Range Dim colTest As Collection Set ws1 = Worksheets("日程表") Set ws2 = Worksheets("日程リスト") Set colTest = New Collection For Each c In ws1.Range("C9:AG43").SpecialCells(xlCellTypeConstants, xlTextValues) If c.Value <> "" Then '半角スペースで区切って、名前、始め、終わりをコレクションに入れます colTest.Add Item:=c & Space(1) & c.Column - 2 & Space(1) & c.Column - 2 + c.MergeArea.Cells.Count - 1 End If Next c Dim i As Long Dim v As Variant For i = 1 To colTest.Count v = Split(colTest(i)) ws2.Cells(i + 1, 1) = v(0) '名前 If v(1) = v(2) Then 'セルの結合がなく If v(1) = 1 Then '1日だったら ws2.Cells(i + 1, 3) = v(2) '終わり Else ws2.Cells(i + 1, 2) = v(1) '始め End If Else ws2.Cells(i + 1, 2) = v(1) '始め ws2.Cells(i + 1, 3) = v(2) '終わり End If Next i End Sub