『列の並び替えと削除』(ぱんだ)
マクロで列の並び変えと不要列の削除をしたいです。
マクロの入っている設定シートの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
マナ様ご提示の下記コードで、
元データのある列にハイパーリンクが各セルに埋め込まれている場合、
並び替えしたり不要列削除するとリンクが切れてしまいます。
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
(ぱんだ) 2024/04/09(火) 23:23:41
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.