Excel データの並び替えについて

縦に並んでいるA,B,C,D のデータを横に行と列を入れ替えて新しいシートＡ１からマクロを使用して名前が変わったら改行して間を１行開けてA列に並べたいのですが、下記のコードでは左詰めができずにうまく動作しません。解決法をどなたか教えていただけませんか。よろしくお願いいたします。

Sub TData()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim TargetRow As Long
Dim nameCol As Long
Dim dateCol As Long
Dim time1Col As Long
Dim time2Col As Long
Dim currentName As String

' ソースシートとターゲットシートの設定
Set wsSource = ThisWorkbook.Sheets("Sheet1) ' ソースシートの名前
Set wsTarget = ThisWorkbook.Sheets.Add ' 新しいシートを作成

' 列のインデックスを設定
nameCol = 1 ' A列
dateCol = 2 ' B列
time1Col = 3 ' C列
time2Col = 4 ' D列

' ターゲットシートの初期行を設定
TargetRow = 1

' 最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, nameCol).End(xlUp).Row

' ソースデータを走査して転記
For i = 1 To lastRow
If wsSource.Cells(i, nameCol).Value <> currentName Then
' 名前が変わった場合、新しい行に移動
TargetRow = TargetRow + 1
currentName = wsSource.Cells(i, nameCol).Value
End If

' 名前、日付、時間1、時間2をターゲットシートに転記
wsTarget.Cells(TargetRow * 4 - 3, i).Value = currentName
wsTarget.Cells(TargetRow * 4 - 2, i).Value = wsSource.Cells(i, dateCol).Value
wsTarget.Cells(TargetRow * 4 - 1, i).Value = wsSource.Cells(i, time1Col).Value
wsTarget.Cells(TargetRow * 4, i).Value = wsSource.Cells(i, time2Col).Value
Next i
End Sub




A列に氏名
B列に日付
C列に開始時間
D列に終了時間

【現状の並び】

氏名1　12/1　開始時間　終了時間
氏名1　12/1　開始時間　終了時間
氏名1　12/3　開始時間　終了時間
　・
　・
氏名1　12/31　開始時間　終了時間
日付12/31

月末まで氏名1のデータが続きます。
次に氏名2が続きます。


氏名2　12/1　開始時間　終了時間
氏名2　12/2　開始時間　終了時間
氏名2　12/3　開始時間　終了時間
　・
　・
氏名2　12/31　開始時間　終了時間

　・
　・
　・
　・
（上記のようなデータが1000以上続く）


【上記を下記のような形ににしたいです】

氏名1　　　　氏名1　　　　氏名1　　　　氏名1　
12/1　　　　12/2　　　　12/3　　　　12/31　
開始時間　　 開始時間　　 開始時間　　 開始時間
終了時間　　 終了時間　　 終了時間　　 終了時間

氏名2　　　　氏名2　　　 氏名2　　　　氏名2　
12/1　　　　12/2　　　　12/3　　　　12/31　
開始時間　　 開始時間　　 開始時間　　 開始時間
終了時間　　 終了時間　　 終了時間　　 終了時間

氏名3　　　　氏名3　　　　氏名3　　　　氏名3　
12/1　　　　12/2　　　　12/3　　　　12/31　
開始時間　　 開始時間　　 開始時間　　 開始時間
終了時間　　 終了時間　　 終了時間　　 終了時間


【現状先のコードを実行すると】

氏名1　　　　氏名1　　　　氏名1　　　　氏名1　
12/1　　　　12/2　　　　12/3　　　　12/31　
開始時間　　 開始時間　　 開始時間　　 開始時間
終了時間　　 終了時間　　 終了時間　　 終了時間


　　　　　　　　　　　　　　　　　　　　　　　　氏名2　　　　氏名2　　
　　　　　　　　　　　　　　　　　　　　　　　　12/1　　 　 12/2
　　　　　　　　　　　　　　　　　　　　　　　　開始時間　　 開始時間
　　　　　　　　　　　　　　　　　　　　　　　　終了時間　　 終了時間　

　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　

現状先のコードを実行すると左づめができない状態です。

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/01/28 22:06

以下のようにしてください。

Option Explicit

Sub TData()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim TargetRow As Long
Dim nameCol As Long
Dim dateCol As Long
Dim time1Col As Long
Dim time2Col As Long
Dim currentName As String
Dim i As Long
Dim name_no As Long '名前番号（1からの通番）
Dim data_no As Long '同一名前内のデータ番号（１からの通番）
name_no = 0
currentName = ""
' ソースシートとターゲットシートの設定
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' ソースシートの名前
Set wsTarget = ThisWorkbook.Sheets.Add ' 新しいシートを作成

' 列のインデックスを設定
nameCol = 1 ' A列
dateCol = 2 ' B列
time1Col = 3 ' C列
time2Col = 4 ' D列

' ターゲットシートの初期行を設定
TargetRow = 1

' 最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, nameCol).End(xlUp).Row

' ソースデータを走査して転記
For i = 1 To lastRow
If wsSource.Cells(i, nameCol).Value <> currentName Then
'名前が変わったら名前番号に１加算
name_no = name_no + 1
data_no = 1
currentName = wsSource.Cells(i, nameCol).Value
End If
TargetRow = (name_no - 1) * 4 + 1
' 名前、日付、時間1、時間2をターゲットシートに転記
wsTarget.Cells(TargetRow, data_no).Value = currentName
wsTarget.Cells(TargetRow + 1, data_no).Value = wsSource.Cells(i, dateCol).Value
wsTarget.Cells(TargetRow + 2, data_no).Value = wsSource.Cells(i, time1Col).Value
wsTarget.Cells(TargetRow + 3, data_no).Value = wsSource.Cells(i, time2Col).Value
data_no = data_no + 1
Next i
End Sub

No.1 回答者： fujillin 回答日時： 2024/01/28 21:47

こんばんは

＞解決法をどなたか教えていただけませんか。
原因は、記入する列のコントロールをしていないことですね。

コード中のコメントで
＞' 名前が変わった場合、新しい行に移動
として、記入行を移動（+1）していますけれど、列は何もしていません。
同時に記入列を1（＝A列）に戻せば良いのですけれど。

ところが、ご提示のコードでは記入列の制御としては
＞For i = 1 To lastRow
というループの中で
＞wsTarget.Cells(TargetRow * 4 - 3, i).Value = ~~
のように、元シートの行番号を、記入シートの列番号にしているので列が戻ることがないようになっています。

変数 TargetRow と同じようにして、記入列も制御すればお望みのようにできると思います。