arrays - Agregar, clasificar y transponer filas en columnas

excel excel-vba

Question

Tengo la siguiente tabla

 Id Letter
1001 A
1001 H
1001 H
1001 H
1001 B
1001 H
1001 H
1001 H
1001 H
1001 H
1001 H
1001 A
1001 H
1001 H
1001 H
1001 B
1001 A
1001 H
1001 H
1001 H
1001 B
1001 B
1001 H
1001 H
1001 H
1001 B
1001 H
1001 A
1001 G
1001 H
1001 H
1001 A
1001 B
1002 B
1002 H
1002 H
1002 B
1002 G
1002 H
1002 B
1002 G
1002 G
1002 H
1002 B
1002 G
1002 H
1002 H
1002 G
1002 H
1002 H
1002 H
1002 H
1002 H
1002 M
1002 N
1002 G
1002 H
1002 H
1002 M
1002 M
1002 A
1002 H
1002 H
1002 H
1002 A
1002 B
1002 B
1002 H
1002 H
1002 H
1002 B
1002 H
1002 H
1002 H
1002 A
1002 A
1002 A
1002 H
1002 H
1002 H
1002 H
1002 B
1002 H
1003 G
1003 H
1003 H
1003 N
1003 M

Y estoy tratando de transponerlo para que cada ID diferente en la primera columna y todas las letras en la segunda columna con un espacio en blanco para cada fila en blanco en la tabla original:

1001 AHHH BHHH HHH AHHHB AHHHB BHHHB H AGHHAB
1002 BHHB GH BGGH BGHH GHH HHHMN GHHMM AHHHAB BHHH BHHHAA AHHHHB H
1003 GHHNM

Tengo alrededor de 100 ID diferentes. Traté de hacer con una fórmula usando TRANSPOSE y TRIM. También probé con una macro y VLOOKUP parece ser la forma más fácil, pero no puedo descubrir cómo

Answer 1

Esta opción incorpora matrices. Desde el punto de vista del rendimiento, es mucho más rápido leer una vez los datos de la hoja de trabajo en una matriz, realizar sus procedimientos directamente en VBE y escribir los resultados en las hojas de trabajo en comparación con los procedimientos en la hoja de trabajo celda por celda.

Sub transposing()
Const sDestination As String = "D2"
Dim ar1() As Variant
Dim ar2() As Variant
Dim i As Long ''counter
ar1 = ActiveSheet.Range("A2:B" & ActiveSheet.UsedRange.Rows.Count).Value
ReDim ar2(1 To 1, 1 To 2)
ar2(1, 1) = ar1(1, 1): ar2(1, 2) = ar1(1, 2)
For i = 2 To UBound(ar1, 1)
If ar1(i, 1) = ar2(UBound(ar2, 1), 1) Then
ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
ElseIf ar1(i, 1) = vbNullString Then
ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & " "
Else
ar2 = Application.Transpose(ar2)
ReDim Preserve ar2(1 To 2, 1 To UBound(ar2, 2) + 1)
ar2 = Application.Transpose(ar2)
ar2(UBound(ar2, 1), 1) = ar1(i, 1)
ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
End If
Next
ActiveSheet.Range(sDestination).Resize(UBound(ar2, 1), UBound(ar2, 2)).Value = ar2
End Sub

El resultado se verá así:

La línea Const sDestination As String = "D2" indica el comienzo de la salida. Cámbielo a la celda que desee.

Answer 2

No puede concatenar un rango de celdas (también conocido como Letras ) utilizando funciones de hoja de cálculo nativas sin conocer el alcance de antemano. Como su colección de cadenas en grupos tiene números aleatorios de elementos, un enfoque de bucle VBA parece la mejor (si no la única) forma de abordar el problema. El bucle puede hacer determinaciones en el camino en que una función de hoja de trabajo es simplemente incapaz de realizar.

Toque Alt + F11 y cuando se abra el Editor de Visual Basic (también conocido como VBE), use inmediatamente los menús desplegables para Insertar ► Módulo ( Alt + I , M ). Pegue uno o ambos de los siguientes en el nuevo panel titulado algo así como Libro1 - Módulo1 (Código) .

Para concatenar los grupos de cadenas delimitados por un espacio:

Sub concatenate_and_transpose_to_delim_string()
Dim rw As Long, lr As Long, pid As Long, str As String
Dim bPutInColumns As Boolean
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).row
.Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
pid = .Cells(2, 1).Value
For rw = 2 To lr
If IsEmpty(.Cells(rw, 1)) Then
str = str & Chr(32)
If pid <> .Cells(rw + 1, 1).Value Then
.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
.Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
End If
ElseIf pid <> .Cells(rw, 1).Value Then
pid = .Cells(rw, 1).Value
str = .Cells(rw, 2).Value
Else
str = str & .Cells(rw, 2).Value
End If
Next rw
.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
.Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
End With
End Sub

Para dividir los grupos de cadenas en columnas:

Sub concatenate_and_transpose_into_columns()
Dim rw As Long, lr As Long, nr As Long, pid As Long, str As String
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).row
.Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
For rw = 2 To lr
If IsEmpty(.Cells(rw, 1)) Then
.Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
str = vbNullString
ElseIf pid <> .Cells(rw, 1).Value Then
pid = .Cells(rw, 1).Value
nr = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).row
.Cells(nr, 4) = pid
str = .Cells(rw, 2).Value
Else
str = str & .Cells(rw, 2).Value
End If
Next rw
.Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
End With
End Sub

Toque Alt + Q para volver a su hoja de trabajo. Con sus datos de muestra en la hoja de trabajo activa comenzando con Id en A1, toque Alt + F8 para abrir el cuadro de diálogo Macros y Ejecutar la macro.

Resultados de concatenate_and_transpose_to_delim_string:

Resultados de concatenate_and_transpose_into_columns:

Los resultados se escribirán en las celdas comenzando en D2. Probablemente sea mejor si no hubiera nada importante allí de antemano que pudiera sobrescribirse.

Apéndice:

Originalmente interpreté mal su solicitud y dividí los grupos de cadenas en columnas separadas. Lo rectifiqué con una rutina complementaria que sigue más de cerca su descripción de los requisitos, pero mantuvo ambas variaciones para que otros las consulten.

Answer 3

Para tareas como esta, Microsoft agregó "Obtener y transformar" a Excel 2016. Para usar esta funcionalidad en versiones anteriores, debe usar el complemento Power Query. El código M es muy corto:

let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
FillIdDown = Table.FillDown(Source,{"Id"}),
ReplaceNull = Table.ReplaceValue(FillIdDown,null," ",Replacer.ReplaceValue,{"Letter"}),
Transform = Table.Group(ReplaceNull, {"Id"}, {{"Count", each Text.Combine(_[Letter])}})
in
Transform

Sus datos deben estar en "Tabla1". https://www.dropbox.com/s/bnvchofmpvd048v/SO_AggregateCollateAndTransposeColsIntoRows.xlsx?dl=0