『空白セルを削除して左に詰める・・・をコードに追加』（りゆうの） https://www.excel.studio-kazu.jp/kw/20240503213030.html の質問に便乗させていただきます。 当方はこのような一覧表を使っています。 A列　　　B列　　　C列　 　D列　　　E列　　　F列 日付　　曜日　　外出者　　外出者　　外出者　　外出者 1　　　　水　　　伊藤　　　鈴木　　　田中 2　　　　木　　　鈴木　　　坂本　　　　　　　　佐々木 3　　　　金 6　　　　月　　　森　 7　　　　火　　　長谷川　　　　　　　田中　　　　加藤 この一覧表を以下のようにする場合、 A列　　　B列　　　C列 日付　　曜日　　外出者 1　　　　水　　　伊藤 1　　　　水　　　鈴木 1　　　　水　　　田中 2　　　　木　　　鈴木 2　　　　木　　　坂本 2　　　　木　　　佐々木 3　　　　金 6　　　　月　　　森　 7　　　　火　　　長谷川 7　　　　火　　　田中 7　　　　火　　　加藤 Sub test() Dim v, w, i&, j&, k& v = Cells(1).CurrentRegion ReDim w(1 To (UBound(v, 2) - 2) * UBound(v), 1 To 3) w(1, 1) = "日付": w(1, 2) = "曜日": w(1, 3) = "外出者" k = 2 For i = 2 To UBound(v) For j = 3 To UBound(v, 2) w(k, 1) = v(i, 1) w(k, 2) = v(i, 2) If v(i, j) = Empty Then If j = 3 Then k = k + 1 Exit For Else w(k, 3) = v(i, j) k = k + 1 End If Next Next With Worksheets.Add.Cells(1).Resize(UBound(w), 3) .Value = w .Columns(1).NumberFormatLocal = "d" .Columns(2).NumberFormatLocal = "aaa" End With End Sub のコードのどこに何を足せば上のような表にできるのか どなたか教えていただけないでしょうか？ [20240503213030]の表との違いは 名前と名前の間に空白セルがあることです。 最初の一覧表の時点で《Ctrl+G》を使って空白セルを左詰めにする方法もありますが、 当方はVBAのコードに組み込みたいのが希望です。 よろしくお願いいたします。 ＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞ ---- 一般操作でできるのならマクロの記録をしてみるとVBAコードがわかる （ぞ） 2024/05/05(日) 04:59:34 ---- 前の質問者さんじゃないんですか？ それは置くとして、VBAで空白セルを左詰めにする方法でいいと思いますよ？ どこまでご自分でトライされているんですか？ それを書いたうえで質問されたほうがよいと、個人的には思いました。 配列を使わない方法で書いて見ました。参考にしてみてください。 Sub test() Dim ws1 As Worksheet, ws2 As Worksheet Dim rng As Range Dim p&, num&, k& Set ws1 = Worksheets("Sheet1") '■要修正 Set ws2 = Worksheets.Add With ws1 '空白セルを左詰め Set rng = .[A1].CurrentRegion rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft '横持データを縦持ちデータに変換 ws2.[A1:C1].Value = .[A1:C1].Value '見出し行を作成 p = 2 For k = 2 To .Cells(Rows.Count, "A").End(xlUp).Row num = .Cells(k, Columns.Count).End(xlToLeft).Column - 2 'その日の外出者の数 If num = 0 Then '外出者が無い場合は日付だけコピーペイスト .Cells(k, 1).Resize(1, 2).Copy ws2.Cells(p, "A") p = p + 1 Else 'それ以外は、外出者を縦に並べる .Cells(k, 1).Resize(1, 2).Copy ws2.Cells(p, "A").Resize(num, 2) ws2.Cells(p, "C").Resize(num, 1) = _ Application.Transpose(.Cells(k, "C").Resize(1, num)) p = p + num End If Next End With End Sub ちなみに、前回スレッドのコードですが、 最後の日が外出者ひとりとかだと、 日付だけの行が一行余分に書き出されませんでしたか? 少し気になりました。 （xyz） 2024/05/05(日) 06:32:09 ---- ＞日付だけの行が一行余分に書き出されませんでしたか? 少し気になりました。 xyzさん、ご指摘ありがとうございます。 まさにその通りでありまして、お恥ずかしい限りです。 質問者さんにはご迷惑お掛け致しました。（前スレ訂正しました） Sub test() Dim v, w, x Dim i&, j&, k& Dim flg As Boolean With Cells(1).CurrentRegion x = .Value On Error Resume Next .SpecialCells(xlCellTypeBlanks).Delete xlToLeft On Error GoTo 0 v = .Value .Value = x End With ReDim w(1 To (UBound(v, 2) - 2) * UBound(v), 1 To 3) w(1, 1) = "日付": w(1, 2) = "曜日": w(1, 3) = "外出者" k = 2 For i = 2 To UBound(v) flg = False For j = 3 To UBound(v, 2) If Not v(i, j) = Empty Then w(k, 1) = v(i, 1) w(k, 2) = v(i, 2) w(k, 3) = v(i, j) k = k + 1 flg = True End If Next If Not flg Then w(k, 1) = v(i, 1) w(k, 2) = v(i, 2) k = k + 1 End If Next With Worksheets.Add.Cells(1).Resize(k, 3) .Value = w .Columns(1).NumberFormatLocal = "d" .Columns(2).NumberFormatLocal = "aaa" End With End Sub （羊カウント） 2024/05/05(日) 08:14:31 ---- 既に解決しているとおもいますが、研究用として私も２案ほど提示しておきます。 ※完成品プレゼントの意図はありませんので、そのまま丸パクリはご遠慮ください。 ■１ 《Ctrl+G》を使って空白セルを左詰めはそのまま採用 （ただし、元データをいじらないように作業用シートに丸ごとコピーしてから作業するように変更） A〜C列までは強制的にコピー D列以降は、データがある部分までA〜B及びその列のデータをコピー Sub 配列なしバージョン() Dim tmpSH As Worksheet, dstSH As Worksheet Dim 行 As Long, 出力行 As Long, 列 As Long Worksheets("Sheet1").Copy after:=Worksheets("Sheet1") Set tmpSH = Worksheets("Sheet1").Next Set dstSH = Worksheets.Add tmpSH.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft tmpSH.Rows(1).Delete Worksheets("Sheet1").Range("A1:C1").Copy dstSH.Range("A1") 出力行 = 2 With tmpSH.Range("A1").CurrentRegion For 行 = 1 To .Rows.Count .Cells(行, 1).Resize(, 3).Copy dstSH.Cells(出力行, "A") 出力行 = 出力行 + 1 For 列 = 4 To tmpSH.Cells(行, Columns.Count).End(xlToLeft).Column Union(.Cells(行, 1).Resize(, 2), .Cells(行, 列)).Copy dstSH.Cells(出力行, "A") 出力行 = 出力行 + 1 Next 列 Next 行 End With Application.DisplayAlerts = False tmpSH.Delete Application.DisplayAlerts = True End Sub D列以降に複数データがある場合、xyzさんは行列入れ替えで一括処理をしていますが、上記は組み合わせごとに逐一コピペしているのでデータ数が多い場合はその分時間がかかることになるので速度的に不利だとおもいます。 Transposeで入れ替えられないほどデータがあるときなどは一考の価値があるかもしれません。 ■２ 上記の発想の延長。 Sub 配列使用バージョン() Dim 行 As Long, 列 As Long, x As Long Dim 配列() As Variant With Worksheets("Sheet1").Range("A1").CurrentRegion .Cells(1, 1).Resize(, 3).Copy dstSH.Range("A1") ReDim 配列((.Rows.Count - 1) * (Columns.Count - 1), 2) For 行 = 2 To .Rows.Count 配列(x, 0) = .Cells(行, "A").Value 配列(x, 1) = .Cells(行, "B").Value 配列(x, 2) = .Cells(行, 3).Value x = x + 1 For 列 = 4 To .Columns.Count If .Cells(行, 列).Value <> "" Then 配列(x, 0) = .Cells(行, "A").Value 配列(x, 1) = .Cells(行, "B").Value 配列(x, 2) = .Cells(行, 列).Value x = x + 1 End If Next 列 Next 行 End With With Worksheets.Add .Range("A1:C1").Value = Array("日付", "曜日", "外出者") .Range("A2").Resize(UBound(配列, 1) + 1, UBound(配列, 2) + 1).Value = 配列 End With End Sub 羊カウントさんのコードとほぼ変わりませんが、空白セルを左詰めする作業はせず、「■１」と同様、C列は強制取得、D列以降はデータがあるとき（""でないとき）だけ取得するようにしています。 ■３ 余談になりますが、配列を使うほうは[[20240415115253]]でも話題にあがりましたので、そちらも参考にされるとよいとおもいます。 （もこな２） 2024/05/05(日) 12:49:06 ---- 羊カウントさん 早速の対応に、質問者さんに成り代わって感謝申し上げます。お疲れさまでした。 （xyz） 2024/05/05(日) 16:37:58 ---- XYZ　様 前の質問者さんと酷似の表を使っているので その表をお借りして質問しました。 VBAは勉強を始めたばかりでほとんど何もわからず トライしたのはExcelの基本操作でなんとかできないか、くらいでした（それが《Ctrl+G》でした） お書きいただいたコードで期待通りの一覧表に変更することができました。 大変助かりました。 ありがとうございました。 （りゆうの） 2024/05/05(日) 20:30:19 ---- 羊カウント　様 日付だけの行が一行余分に書き出されてしまう件と、 空白セルを左詰めする件と合わせて、 前回のコードと訂正されたコードを見比べ どこをどう修正したらいいのかを勉強するための参考にいたします。 （とはいえ、当方、まだまだそこまでのレベルまで達していないのですが） ご丁寧な回答ありがとうございました。 （りゆうの） 2024/05/05(日) 20:32:04 ---- もこな２　様 2案、そして過去スレの紹介、ありがとうございます。 VBAは勉強を始めたばかりで現段階ではわからないことだらけなのですが、 2案と過去スレの内容は、自力で完成度の高いコードが書けるようになるための参考になります。 ご丁寧な回答ありがとうございました。 （りゆうの） 2024/05/05(日) 20:34:16