Макрос VBA для обмена столбцами

Question

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

например есть 4 столбца

Supplier1, Supplier2, Оценка поставщика1, Оценка поставщика2

Я хочу изменить столбцы, как показано ниже

Supplier1, оценка поставщика1, поставщик2, оценка поставщика2

Я использовал приведенный ниже код

Столбцы ("I:").Выберите Выбор.Вырезать колонны («D:D»).Выберите Выбор.Вставить Shift:= xlToRight

Answer 1

Вы можете найти код, который я разместил в моем мини-блоге, чтобы быть интересным ...

http://www.excelfox.com/forum/f22/swapping-rearranging-multiple-columns-of-data-493/

Answer 2

Ваши характеристики не совсем понятны. Но, похоже, вы хотите чередовать первую половину столбцов со второй. Это может быть сделано довольно просто и быстро в VBA. Я сделал предположения, которые вам нужно будет отредактировать, где находится исходные данные и где вы хотите разместить результаты. Я также предположил, что данные являются смежными, как отмечено в комментариях к коду.

Это достигается в массивах VBA, так как процедуры, которые постоянно обращаются к рабочему листу, работают намного медленнее.

Используемый алгоритм:

• Считать данные в массив 2D-вариантов
• создайте второй массив для хранения результатов того же размера, что и первый
• заполнить второй массив, чередуя диапазоны первой и второй половины столбца.
• записать массив результатов в диапазон листа.
• отформатировать результаты

---

Option Explicit
Sub InterleaveColumns()
    Dim wsORIG As Worksheet, wsRESULT As Worksheet, rRESULT As Range
    Dim lNumCols As Long
    Dim vORIG As Variant, vRESULT() As Variant
    Dim I  As Long, J As Long

'Place Results starting on Sheet3!A1
Set wsRESULT = Worksheets("Sheet3")
Set rRESULT = wsRESULT.Cells(1, 1)

'Assuming the data table starts Sheet2!A1 and is contiguous
'Adjust algorithm as required
Set wsORIG = Worksheets("Sheet2")

'Place data into a 2D Variant Array
vORIG = wsORIG.Cells(1, 1).CurrentRegion

'Number of columns
lNumCols = UBound(vORIG, 2)

'Sanity check
If lNumCols Mod 2 <> 0 Then
    MsgBox ("Must have Even number of columns")
    Exit Sub
End If

'Create results array
ReDim vRESULT(1 To UBound(vORIG, 1), 1 To UBound(vORIG, 2))

'Populate results array with interleaving
For I = 1 To UBound(vORIG, 1)
    For J = 1 To UBound(vORIG, 2) / 2
        vRESULT(I, (J - 1) * 2 + 1) = vORIG(I, J)
        vRESULT(I, (J - 1) * 2 + 2) = vORIG(I, J + lNumCols / 2)
    Next J
Next I

'Write results array to some worksheet and range
Set rRESULT = rRESULT.Resize(UBound(vRESULT, 1), UBound(vRESULT, 2))
With rRESULT
    .EntireColumn.Clear
    .Value = vRESULT
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

---