[[20240407130929]]　『列の並び替えと削除』（ぱんだ）　ページの最後に飛ぶ

『列の並び替えと削除』（ぱんだ）

マクロで列の並び変えと不要列の削除をしたいです。
マクロの入っている設定シートの3行目に最終的に残したい項目名がA3セルからD3セルまで書いています。

A3 B3 C3 D3
F　　G 　 I E

並び替えと列削除したいファイルは別にあり、
同様に3行目のA列からJ列まで項目名が並んでいます。
(事例は分かりやすいように項目名をアルファベットにしています。4行目から1000行目までの表です。

A B C D E F G H I J

下記、考えたコードですと、残したい列だけになるものの、順番がかわりません。ご教授いただけますでしょうか。

関係部分のみ抜粋

   With データシート
       ' 列の並び替えと削除を実施
        Dim 条件範囲 As Range
        Dim 条件セル As Range
        Dim i As Integer
        Dim j As Integer
        Set 条件範囲 = 設定シート.Range("A3").CurrentRegion
        For i = .Cells(3, .Columns.count).End(xlToLeft).Column To 1 Step -1
            Dim 存在する As Boolean
            存在する = False
            For Each 条件セル In 条件範囲.Rows(1).Cells
                If .Cells(3, i).value = 条件セル.value Then
                    存在する = True
                    Exit For
                End If
            Next 条件セル
            If Not 存在する Then
                .Columns(i).Delete
            End If
        Next i
    End With

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 並べ替えるコードは全く記述されていないとお見受けしますが。
 掲載外の部分にあるんですか？
 「関係部分のみ抜粋」では全く分かりません。

 並べ替えに関するコードが記述されていないと前提して、
 一案としてですが、不要な列を削除した後、
 CustomOrderを条件にして、列単位でソートします。

    With データシート
        .Sort.SortFields.Clear
        .Sort.SortFields.Add _
            Key:=.Range("A3"), _
            Order:=xlAscending, _
            CustomOrder:=Join(Application.Transpose(Application.Transpose(条件範囲.Rows(1))), ",")
        .Sort.Orientation = xlSortRows
        .Sort.SetRange .Range("A3").CurrentRegion
        .Sort.Header = xlNo
        .Sort.Apply
    End With
（ニック） 2024/04/07(日) 14:46:41

 Sub test()
    Dim r As Range, c As Range, t As Range

    Set r = Worksheets("データ").Range("A3:J1000")
    Set c = Worksheets("設定").Range("A3:D3")

    Set t = r(1).Offset(, r.Columns.Count).Resize(, c.Count)
    c.Copy t
    r.AdvancedFilter xlFilterCopy, , t
    r.Delete xlToLeft

 End Sub

  Sub test2()
    Dim r As Range, c As Range, m, v

    Set r = Worksheets("データ").Range("A3:J1000")
    Set c = Worksheets("設定").Range("A3:D3")

        m = Application.XMatch(c, r.Rows(1))
        v = Application.Index(r.Value, Evaluate("row(1:" & r.Rows.Count & ")"), m)
        r.Offset(, r.Columns.Count).Resize(, c.Count).Value = v
        r.Delete xlToLeft

 End Sub
（マナ） 2024/04/07(日) 15:31:24

ニック様、マナ様
ありがとうございます。
いろいろなアプローチ方法があるのですね。
引き出しを増やして、その時その時で一番良い方法を組み込めるようになりたいと思います。
ありがとうございます。
（ぱんだ） 2024/04/07(日) 17:39:29

追加の質問となってしまいすみません。
教えてください。

マナ様ご提示の下記コードで、
元データのある列にハイパーリンクが各セルに埋め込まれている場合、
並び替えしたり不要列削除するとリンクが切れてしまいます。
AdvancedFilterだとリンク付きにはリンク保持には対応できないでしょうか。
何か良い方法がありましたら教えてください。

Sub test()

    Dim r As Range, c As Range, t As Range
    Set r = Worksheets("データ").Range("A3:J1000")
    Set c = Worksheets("設定").Range("A3:D3")
    Set t = r(1).Offset(, r.Columns.Count).Resize(, c.Count)
    c.Copy t
    r.AdvancedFilter xlFilterCopy, , t
    r.Delete xlToLeft
 End Sub
（ぱんだ） 2024/04/09(火) 19:05:18

 Sub test3()
    Dim r As Range, c As Range, m

    Set r = Worksheets("データ").Range("A3:J1000")

    For Each c In Worksheets("設定").Range("A3:D3")
        m = Application.XMatch(c, r.Rows(1))
        r.Columns(m).Copy r(1).End(xlToRight).Offset(, 1)
    Next
    r.Delete xlToLeft

 End Sub
（マナ） 2024/04/09(火) 22:06:57

ありがとうございます。
家のパソコンがOffice365に対応しておらず実際に試せていませんが、
明日やってみたいと思います。

（ぱんだ） 2024/04/09(火) 23:23:41

コメント返信：

[ 一覧(最新更新順) ]

[[20240407130929]] 『列の並び替えと削除』（ぱんだ） ページの最後に飛ぶ

[[20240407130929]]　『列の並び替えと削除』（ぱんだ）　ページの最後に飛ぶ