Excel VBA - 一致する列の見出しを見つけて列を削除します

Question

これまでに回答があった場合は謝罪します。特定のケースに一致するものが見つかりません。

私は18枚のシートと、B2から始まる1枚あたりの可変数の列を持つワークブックを持っています。時には、シートを生成するプログラムが重複した列を作成することがあります。このため、各シートで一致する列ヘッダーを検索し、これらの列（ヘッダーだけでなく列全体）を削除するボタンでトリガーされたマクロが必要です。

これまでのところ、私はかなり固執しています。シート全体のすべてのセルからすべてのマッチを削除することができました。これは、シート全体をかなり拭き取ります。ヘッダーを一致させ、その列に基づいて列全体を削除するだけです。

さらに詳しい情報が必要な場合はお知らせください。ありがとうございました！

私が今までに持っていたことは、コードが他のものもやっているので、これは動作を続ける必要があるからです。

Sub RemoveExtras() 

Dim MyRange As Range 
Dim ws As Worksheet 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

BadCharacters = Array(Chr(10), Chr(13)) 
wsNumber = Sheets.Count 

For Each ws In Worksheets 
    With ws 
     For Each MyRange In .UsedRange 
      If 0 < InStr(MyRange, Chr(10)) Then 
      For Each i In BadCharacters 
       MyRange = Replace(MyRange, i, vbNullString) 
      Next i 
      End If 
      For t = 1 To wsNumber 
       Columns(t).RemoveDuplicates Columns:=Array(1), Header:=xlYes 
       Next t 
     Next MyRange 
    End With 
Next ws 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub 

Answer 1

辞書に役立ちますかどうかを確認し、一意の値を処理するための最適です：

Sub RemoveExtras() 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim c As Integer, i As Integer, ws As Worksheet 
Dim dict As Object 


For Each ws In Worksheets 

    Set dict = CreateObject("Scripting.Dictionary") 
    'Find Last column 
    c = ws.UsedRange.Columns.Count 

    'Loop backwards 
    For i = c To 2 Step -1 

     'If column does not exist in dictionary, then add it 
     If Not dict.Exists(ws.Cells(2, i).Value) Then 
      dict.Add ws.Cells(2, i).Value, 1 
     Else 
     'Otherwise delete column 
      ws.Columns(i).Delete Shift:=xlToLeft 
     End If 

    Next i 
    Set dict = Nothing 
Next 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 



End Sub 

ここでは、シートの列ヘッダーのすべてのペアを比較しません。また、これは、個々のシート内の重複だけでなく、すべてのワークシートにわたるヘッダーを比較します。

Answer 2

これはあなた

Sub test() 

Dim book As Workbook, sheet As Worksheet, text As String 

For Each sheet In Worksheets 


    Set MR = Range("B2:Z2") 'change Z2 as per your requirement 
    For Each cell In MR 
     Set BR = Range("B2:Z2") 'change Z2 as per your requirement 
     For Each cell2 In BR 
      If cell.Value = cell2.Value Then cell.EntireColumn.Delete 
     Next 
    Next 

Next sheet 


End Sub