Excelマクロで空白セルを詰めて別シートに転記するにはどうすればよいでしょうか？

Sheet1のようなデータを空白セルを詰める形でSheet2に貼り付けたいと考えています（図を参照）。
1行だけであれば下記のコードでできるところまではたどり着きました。
Sub 空白を詰める()
Dim i As Long
Dim j As Long
Dim k As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
i = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
j = 1
For k = 1 To i
If sh1.Cells(1, k) <> "" Then
sh2.Cells(1, j) = sh1.Cells(1, k)
j = j + 1
End If
Next k
End Sub
複数行のデータに対して同様の処理を行うにはどうすればよいでしょうか？
ご教示願います。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2024/09/04 14:08

こんにちは

A列の最終行がデータの最終行と一致しない場合は
SpecialCells(xlLastCell).Rowを使うと良いかもしれません
また、最終列が行によって違う場合は　変数で対象行を指定するか同様に
Range("A1").SpecialCells(xlLastCell).Columnなどを使用しますが
この場合、最大（最後の）行まで処理されるので無駄な処理がされる可能性があります
ご質問のロジックの延長で１例はこんな感じ
ステップ実行などで動作を確認してみてください

Dim i As Long
Dim j As Long
Dim k As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
Dim n As Long
i = 1
For n = 1 To sh1.Range("A1").SpecialCells(xlLastCell).Row
j = 1
For k = 1 To sh1.Cells(n, Columns.Count).End(xlToLeft).Column
If sh1.Cells(n, k) <> "" Then
sh2.Cells(i, j) = sh1.Cells(n, k)
j = j + 1
End If
Next k
i = i + 1
Next n

この回答へのお礼

ご回答いただきありがとうございます。
うまくできました！
Sheet1のA列には全行データがある状態ですので、列方向のみケアすればよいと思いますが、データ行が多い場合は確かに余計な処理を行うことになりますね。実データで挙動を確認してみます。
ありがとうございました。

お礼日時：2024/09/04 14:44

No.5 回答者： fujillin 回答日時： 2024/09/04 17:54

こんばんは

詰めるというよりも、空白セルをまとめて除去すると考えると簡単だと思います。
以下のような要領でも可能と思います。

Sub Sample()
　With Worksheets("Sheet2")
　　Worksheets("Sheet1").Cells.Copy .Cells
　　.UsedRange.SpecialCells(xlCellTypeBlanks).Delete (xlShiftToLeft)
　End With
End Sub

この回答へのお礼

こんばんは。
ご回答いただきありがとうございます。
なるほど。こういうアプローチもありですね。
構文もシンプルですし面白いですね。
参考になります。

お礼日時：2024/09/04 19:44

No.4 回答者： ssawatake 回答日時： 2024/09/04 14:57

>>全データ中の列maxを取得する方法はありますでしょうか？

ゴメン、見落とし有りました

i = sh1.Cells(1, Columns.Count).End(xlToLeft).Column

↓1を行に変更

i = sh1.Cells(行, Columns.Count).End(xlToLeft).Column

この回答へのお礼

ありがとうございます。
きれいにできました！

お礼日時：2024/09/04 15:10

No.3 回答者： いんちょ 回答日時： 2024/09/04 14:37

Sheet2のA1セルに

=TextSplit(TextJoin(",",TRUE,Sheet1!1:1),",")
と書けばできます。
VBAでやりたければTextJoinをWorksheeFunctionで呼んで、
Splitで分割して順に貼り付ければいいでしょう。

この回答へのお礼

なるほど。こういう方法もあるのですね。
古いバージョンのExcelも稼働している環境ですので難しい面もありますが勉強になります。
ご回答いただきありがとうございました。

お礼日時：2024/09/04 15:05

No.1 回答者： ssawatake 回答日時： 2024/09/04 13:44

今のforループを囲むforループを追加する。

囲むforループを行方向でループさせる。

行max= sh1.Range("A65536").End(xlUp).Row　←追加
for 行=1 to 行max　←追加

i = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
j = 1
For k = 1 To i
If sh1.Cells(行, k) <> "" Then　　←1を行に変更
sh2.Cells(行, j) = sh1.Cells(行, k)　　←1を行に変更
j = j + 1
End If
Next k

Next 行　←追加

この回答へのお礼

ご回答いただきありがとうございます。
教えていただいたコードを追加してみました。
2行目　かきくけ
3行目　さしすせ
となってしまいますね。
i（列のmax）を1行目で取ってしまっているからだと思いますが、全データ中の列maxを取得する方法はありますでしょうか？
重ねてのお尋ねになり申し訳ありません。

お礼日時：2024/09/04 14:16