macro VBA para trocar colunas

Question

Por favor, você poderia me ajudar na macro VBA para trocar colunas

por exemplo, existem 4 colunas

Fornecedor1, Fornecedor2, Classificação do Fornecedor1, Classificação do Fornecedor2

Eu quero alterar as colunas conforme abaixo

Fornecedor1, Fornecedor1, Fornecedor2, Fornecedor2

Eu usei o código abaixo

Colunas ("I: I"). Selecione Selection.Cut Colunas ("D: D"). Selecione Seleção.Inserir Shift: = xlToRight

    

Answer 1

Você pode achar que o código que postei no meu mini-blog aqui é de algum interesse ...

link

    

Answer 2

Suas especificações não são totalmente claras. Mas parece que você quer intercalar a primeira metade de suas colunas com a segunda metade. Isso pode ser feito de maneira simples e rápida no VBA. Eu fiz suposições, que você precisará editar, onde os dados originais estão localizados e onde você deseja colocar os resultados. Eu também assumi que os dados são contíguos, como observado nos comentários do código.

Isso é realizado em arrays VBA, pois as rotinas que acessam repetidamente a planilha são muito mais lentas.

O algoritmo usado:

• Leia os dados em uma matriz de variantes 2D
• crie uma segunda matriz para manter os resultados, mesmo tamanho da primeira
• preencha o segundo array intercalando os intervalos da primeira e segunda metade da coluna.
• escreva a matriz de resultados em um intervalo de planilha.
• formate os resultados

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