[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『空白セルを削除して左に詰める・・・をコードに追加』（りゆうの）
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で空白セルを左詰めにする方法でいいと思いますよ？ どこまでご自分でトライされているんですか？ それを書いたうえで質問されたほうがよいと、個人的には思いました。
配列を使わない方法で書いて見ました。参考にしてみてください。
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
お書きいただいたコードで期待通りの一覧表に変更することができました。
大変助かりました。
ありがとうございました。
（りゆうの） 2024/05/05(日) 20:30:19
（りゆうの） 2024/05/05(日) 20:32:04
（りゆうの） 2024/05/05(日) 20:34:16
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.