Excel VBAで表のフォーマットを変えたい

質問

表題だけでは判らないと思いますので、詳細に実現したいことを箇条書きにて説明いたします。

1.弊社では、電子スケジュール管理ソフトを使っています。
（WEBベースで、部内のメンバーの一週間分の行動が表示できます）

2.現在、その予定表を、女性事務員さんが、ブラウザ上でコピーして、Excelに貼り付け、職位順に並べ替えたり、空白行を削除したりしています。

3.今回の質問は、ブラウザからコピーするところまでは仕方ないとして、その後、決まったフォーマットに編集する作業をVBAを用いて簡便化してあげたいのです。
マクロも考えましたが、ソフトに登録されているスケジュールの数によって行数が変わるため、適していないと判断しました。

（注）当方、VBAの知識はほとんどありません。基本書を読んだくらいで、「ああ、こういうものか」という理解度です。

4.本題ですが、ペーストした状態は、図のとおりです。名前が結合されたセルの右に、一日毎の予定が入力されています。が、時間と予定の内容は別のセルに格納されています。
また、なぜか予定の一番上には空白セルが挿入されています。

5.これを、

　　　日付　　　　　　　　日付　　　　　　　　　日付
--------------------------------------------------------------
Ａ氏｜時間（セル内改行）｜時間（セル内改行）｜
　　｜予定（セル内改行）｜予定（セル内改行）｜
　　｜時間（セル内改行）｜
　　｜予定（セル内改行）｜
--------------------------------------------------------------
Ｂ氏｜時間（セル内改行）｜時間（セル内改行）｜
　　｜予定（セル内改行）｜予定（セル内改行）｜
　　｜時間（セル内改行）｜
　　｜予定（セル内改行）｜
--------------------------------------------------------------

という風に、整理したいのです。

もっと欲を言えば、決められた順序に、名前で並べ替えたいです。

VBAの得意な方、いらっしゃいましたら断片的でも結構ですので、ご教授いただけませんでしょうか？

どうぞよろしくお願いいたします。

回答No.1

nak777r · ベストアンサー

とりあえずこんな感じで、

Sub Macro1()
Dim fromSheet As Worksheet ' 変換元シート
Dim fromTitleRow As Long ' 変換元、日付の行（１行目）
Dim fromNameCol As Long ' 変換元、名前の列（１列目）
Dim fromStartRow As Long ' 変換元、スケジュールの開始行
Dim fromStartCol As Long ' 変換元、スケジュールの開始列
Dim fromEndCol As Long ' 変換元、スケジュール終了列
Dim fromRow As Long ' 変換元、作業を行う行
Dim fromCol As Long ' 変換元、作業を行う列
Dim toSheet As Worksheet ' 変換先シート
Dim toTitleRow As Long ' 変換先、日付の行（１行目）
Dim toNameCol As Long ' 変換先、名前の列（１列目）
Dim toRow As Long ' 変換先、作業を行う行
Dim toCol As Long ' 変換先、作業を行う列
Dim ConnectCount As Long ' 連結数
Dim workRow As Long ' 作業を行う行
Dim addCRLF As String ' 改行処理用

' コピペして貼りつけたシート（変換元）を fromSheet とする
' 日付のある行を１行目とする、名前のある列を１列目とする
Set fromSheet = Worksheets("Sheet1")
fromTitleRow = 1
fromNameCol = 1

' 整形した結果のシート（変換先）を toSheet とする
' 日付のある行を１行目とする、名前のある列を１列目とする
Set toSheet = Worksheets("Sheet2")
toTitleRow = 1
toNameCol = 1

' 変換元
' スケジュールの開始行＝日付の行＋１
' スケジュールの開始列＝名前の列＋１
' スケジュールの終了列＝最初の日付のセルから[CTRL]+[→]で移動した先の列
fromStartRow = fromTitleRow + 1
fromStartCol = fromNameCol + 1
fromEndCol = fromSheet.Cells(fromStartRow, fromStartCol).End(xlToRight).Column

' 出力先のシートをクリアする
' Cells でシート全体を指定しています
' 範囲で指定する場合、(A1セルから F65536セル迄なら）
' toSheet.Range("A1:F65536").～ のように変更します
toSheet.Cells.ClearContents
toSheet.Cells.Borders.LineStyle = xlNone
toSheet.Cells.Interior.ColorIndex = xlNone

' 日付分ループして、日付を toSheetにコピーします
toCol = toNameCol + 1
For fromCol = fromStartCol To fromEndCol
toSheet.Cells(toTitleRow, toCol).Value = fromSheet.Cells(fromTitleRow, fromCol).Value
toCol = toCol + 1
Next fromCol

' 作業を行う行を、スケジュールの開始行にしてループ開始
' ループは名前が無ければ終了
fromRow = fromStartRow
toRow = toTitleRow + 1
Do While (Trim(fromSheet.Cells(fromRow, fromNameCol).Value) <> "")

' toSheet 側に名前をコピーします
toSheet.Cells(toRow, toNameCol).Value = _
fromSheet.Cells(fromRow, fromNameCol).Value

' 名前セルは連結されているので、何個連結しているかを求める、
' １つの予定は、空欄、時刻、予定の３行で記述されているため、
' ループする際は３行とびで行う
ConnectCount = fromSheet.Cells(fromRow, fromNameCol).MergeArea.Count

' 日付分ループ
toCol = toNameCol + 1
For fromCol = fromStartCol To fromEndCol

' toSheet側のスケジュールのセルをクリアします
toSheet.Cells(toRow, fromCol) = ""

' 最終行にCRLFを付けない処理
addCRLF = ""

' 連結数分ループ（３行毎）
For workRow = 0 To ConnectCount Step 3

' 予定をがなければ、その日のループは終了
' 空欄、時刻、予定の３行なので、＋２行目にある予定の文字が空欄か確認
If (Trim(fromSheet.Cells(fromRow + workRow + 2, fromCol).Value) = "") Then
Exit For
End If

' toSheet にスケジュールを追記
' +1 が 時刻の行を示す
' +2 が 予定の行を示す
toSheet.Cells(toRow, toCol).Value = toSheet.Cells(toRow, toCol).Value _
& addCRLF _
& fromSheet.Cells(fromRow + workRow + 1, fromCol).Value & vbCrLf _
& fromSheet.Cells(fromRow + workRow + 2, fromCol).Value
addCRLF = vbCrLf
Next workRow
toCol = toCol + 1
Next fromCol

' 次の人の行に移動
toRow = toRow + 1
fromRow = fromRow + ConnectCount
Loop

' 終了処理
Set toSheet = Nothing
Set fromSheet = Nothing

End Sub

お礼

大感謝です。

これ、発注したらかなりのコストがかかっていたと思います。
もちろん、大満足です。

どうもありがとうございました！

もしお時間がありましたら、第二の願いである、決められた名前順に並び替えるロジックも教えていただければ幸いです。
（VBAソースは別に構えていただいて結構です）

ホント、助かりました。