Tengo una macro que reorganiza las columnas en un orden particular.

Sub ArrangeColumns()

' ArrangeColumns Macro

    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight
    Range("P11").Select
End Sub

Esto ya no funciona porque ya no se puede garantizar que las columnas de los datos sin procesar estén en un orden específico.

¿Hay alguna manera de que pueda reescribir el código anterior (Sí, fue creado por "Grabar macro") para reemplazar las líneas "Columns("C:C")", Columns("A:A")", etc. con sus nombres de encabezado de columna?

Mejor aún, ¿existe un mejor enfoque para este problema?

2
PhilNBlanks 15 oct. 2018 a las 21:12

2 respuestas

La mejor respuesta

Si conoce todos los nombres de los encabezados, puede definir una matriz de los nombres de los encabezados y usar el índice de la matriz para mover las columnas.

Sub columnOrder()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer

colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here

cnt = 1


For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not search Is Nothing Then
        If search.Column <> cnt Then
            search.EntireColumn.Cut
            Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    cnt = cnt + 1
    End If
Next indx
End Sub

Cualquier columna que no se mencione en la matriz aparecerá a la derecha de las mencionadas.

4
oxwilder 15 oct. 2018 a las 19:54

Uso alternativo de Application.Index en una sola línea

En aras del arte y solo para demostrar una alternativa de trabajo utilizando las posibilidades de reestructuración avanzadas de la función Application.Index (c.f. sección [2] ):


Sub colOrder()
' Purpose: restructure range columns
  With Sheet1                                               ' worksheet referenced e.g. via CodeName

    ' [0] identify range
      Dim rng As Range, lastRow&, lastCol&
      lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        ' get last row and last column
      lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))

    ' ~~~~~~~~~~~~
    ' [1] get data
    ' ~~~~~~~~~~~~
      Dim v: v = rng                                        ' assign to 1-based 2-dim datafield array

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' [2] restructure column order in array in a one liner
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      v = Application.Index(v, Evaluate("row(1:" & lastRow & ")"), getColNums(v))

    ' [3] write data back to sheet
      rng = vbNullString                                    ' clear orginal data
      .Range("A1").Resize(UBound(v), UBound(v, 2)) = v      ' write new data

  End With

End Sub

Función auxiliar llamada por el procedimiento principal anterior

La función auxiliar simplemente devuelve una matriz con los números de columna correctos que se encuentran en los títulos actuales; usa Application.Match para encontrar ocurrencias:

Function getColNums(arr) As Variant()
' Purpose: return array of found column number order, e.g. Array(3,2,1,4,6,5)
Dim colOrdr(), titles                                           ' wanted order, current titles
colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here
titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

Dim i&, ii&, pos                                                ' array counters, element position
ReDim tmp(0 To UBound(colOrdr))                                 ' temporary array to collect found positions
For i = 0 To UBound(colOrdr)                                    ' loop through titles in wanted order
    pos = Application.Match(colOrdr(i), titles, 0)              ' check positions
    If Not IsError(pos) Then tmp(ii) = pos: ii = ii + 1         ' remember found positions, increment counter
Next i
ReDim Preserve tmp(0 To ii - 1)                                 ' remove empty elements
getColNums = tmp                                                ' return array with current column numbers (1-based)
End Function

Enlace relacionado

Enumeré algunas peculiaridades de la función Application.Index en Insertar la primera columna en la matriz del campo de datos sin bucles ni llamadas a la API

0
T.M. 27 jun. 2019 a las 16:01