Как выбрать и удалить каждый третий столбец

У меня есть набор данных, где каждый третий столбец один и тот же. Я хочу оставить только первый столбец, а другие, которые должны быть одинаковыми, должны быть удалены.

Сначала я пробовал этот код, но он удалял неправильные столбцы, потому что в каждом цикле другие позиции столбцов были изменены.

Sub DeleteMultipleColumns() Dim i As Integer Dim LastColumn As Long Dim ws As Worksheet Set ws = Sheets("Arkusz2") LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column ws.Activate For i = 4 To (LastColumn - 2) ws.Columns(i).Select Selection.Delete Shift:=xlToLeft i = i + 3 Next i End Sub 

После этого я попробовал другой, используя Union. Это не работает:

 Sub DeleteMultipleColumns() Dim i As Integer Dim LastColumn As Long Dim ws As Worksheet Set ws = Sheets("Arkusz2") LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column ws.Activate For i = 4 To (LastColumn - 2) Application.Union.Columns(i).Select i = i + 3 Next i Selection.Delete Shift:=xlToLeft End Sub 

Итак, как это сделать?

Моя новая идея – попробовать массив. Есть ли у меня другие возможности?

Это код, который я реализовал после ваших очень хороших ответов (спасибо: sam092, meohow, mattboy):

 Sub DeleteMultipleColumns() Dim i As Integer Dim LastColumn As Long Dim ws As Worksheet Application.ScreenUpdating = False Set ws = Sheets("Arkusz2") LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column - 2 For i = LastColumn To 4 Step -3 ws.Columns(i).Delete Shift:=xlToLeft Next i Application.ScreenUpdating = True End Sub 

Переверните направление. Начните удаление справа. Я думаю, вы знаете, как изменить свой код

Вы можете вернуться назад так. Кроме того, вам не нужно выбирать столбец перед удалением, вы можете просто удалить его сразу.

 For i = ((LastColumn \ 4) * 4) To 4 Step -4 ws.Columns(i).Delete Shift:=xlToLeft Next i 

Я поддержал код Мэттбой как самый чистый

Можно избежать цикла диапазона и использовать массив, как вы предлагаете, хотя я отправляю это больше для ударов, поскольку генерация массива сложна

Использование Можно ли заполнить массив номерами строк, которые соответствуют определенным критериям без цикла?

 Sub OneinThree() Dim ws As Worksheet Dim rng1 As Range Dim x As String Set ws = ActiveSheet Set rng1 = Cells(1, ws.Cells(1, Columns.Count).End(xlToLeft).Column - 2) x = Join(Filter(Application.Evaluate("=IF(MOD(column(A1:" & rng1.Address & "),3)=0,address(1,column(a1:" & rng1.Address & ")),""x"")"), "x", False), ",") If Len(x) > 0 Then ws.Range(x).EntireColumn.Delete End Sub 
Давайте будем гением компьютера.