vba 空白を左詰めに時間がかかる

Question

同じ行内で重複があれば削除し、空白を左詰めにする作業を行っています。
下記コードで動くのですが、左詰めにすごく時間がかかります。

他に方法はないでしょうか。
ちなみに、 (xlToLeft)しなければ動きは早いです。

F g1｜Fg2 ｜Fg3 ｜Fg4
aaa｜bbb｜空白 ｜ccc
aaa｜aaa｜空白 ｜空白
ccc｜空白 ｜ccc｜bbb
aaa｜ccc｜bbb｜ddd

Sub sample()
Dim i As Long, j As Long
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 4 To 1 Step -1
If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, 4)), Cells(i, j)) > 1 Or Cells(i, j) = "" Then
Cells(i, j).Delete (xlToLeft)
End If
Next j
Next i
End Sub

Comments

[satokei]

とりあえず、思いついた案ですが、
1. 作業用シートへ行列入れ替えで貼り付け
2. RemoveDuplicatesメソッドで削除
3. 結果を書き戻す

[退会済みユーザー]

RemoveDuplicatesを調べてみたのですが、重複削除するコードであっていますか？
同じ行内の列方向の重複削除まではできていて、削除したセル＝空白を左詰めしたいのですが。
教えて頂いた内容が理解できず申し訳ございません。

[satokei]

RemoveDuplicatesメソッドは、重複行を削除して上へ詰めてくれるメソッドです。
このままでは要件に合わないため、行列入れ替えればできると思った次第です。
ただ処理が速くなるかは不明です。
https://excwlvba.blogspot.com/2013/06/removeduplicates.html

[退会済みユーザー]

ありがとうございます。
上に詰めるにも時間かかりました。

Answer 1

セル範囲を配列に入れ、セルをクリアします。
Dictionaryを利用して重複削除し、セルに戻します。
Microsoft Scripting Library参照設定してください。
（もっと早い方法はあるかもしれません）

Sub sample()
    
    Dim i As Long, j As Long
    Dim ary As Variant
    Dim maxRow As Long: maxRow = Cells(Rows.Count, 1).End(xlUp).Row
    ary = Range(Cells(2, 1), Cells(maxRow, 4))
    Cells.Clear
    For i = 1 To UBound(ary, 1)
        Dim dic As Dictionary
        Set dic = New Dictionary

        For j = 1 To UBound(ary, 2)
            If ary(i, j) <> "" Then
                If Not dic.Exists(ary(i, j)) Then dic.Add ary(i, j), Null
            End If
        Next j

        Cells(i + 1, 1).Resize(, dic.Count) = dic.Keys
        Set dic = Nothing
    Next i
    
End Sub

Comments

[退会済みユーザー]

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

[ryuno_vanilla]

速度はどうだったでしょうか？
セルに１つずつアクセスしているのであまり早くなかったかもしれません。
1か所訂正します。

' For j = 0 To dic.Count - 1
' Cells(i + 1, j + 1).Value = dic.Keys(j)
' Next j
この3行を消して
Cells(i + 1, 1).Resize(, dic.Count) = dic.Keys
の一行に入れ替えてみてください。
もう少し早くなると思います。

回答も編集します。