Concatenar varias celdas con salto de línea por criterio
Tengo una tabla como la siguiente
Y quiero una macro para conseguir este resultado, concatenando en una celda el nombre y los KG y colocar en otra el total de Kg.
1 Respuesta
Checa esta macro
Sub crea_tablas()
Dim unicos As New Collection
Set datos = Range("a1").CurrentRegion
titulos = Array("zona", "Nombre_kg", "total-kg")
With datos
filas = .Rows.Count
Set datos = .Rows(2).Resize(filas - 1)
Set tabla = .Rows(filas + 3).Resize(filas)
.Copy: tabla.PasteSpecial xlPasteAllUsingSourceTheme
End With
With tabla
For i = 1 To filas
.Cells(i, 2) = .Cells(i, 2) & " " & .Cells(i, 3)
zona = .Cells(i, 1)
On Error Resume Next
If zona <> Empty Then unicos.Add zona, CStr(zona)
On Error GoTo 0
Next i
For j = 1 To unicos.Count
zona = unicos.Item(j)
cuenta = WorksheetFunction.CountIf(.Columns(1), zona)
fila = WorksheetFunction.Match(zona, .Columns(1), 0)
With .Rows(fila).Resize(cuenta, 1)
.ClearContents
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Value = zona
End With
Set kilos = .Cells(fila, 3).Resize(cuenta, 1)
With kilos
suma = WorksheetFunction.Sum(kilos)
.ClearContents
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Value = suma
End With
Next j
.Rows(0) = titulos
datos.Rows(0).Copy: .Rows(0).PasteSpecial xlPasteFormats
.EntireColumn.AutoFit
End With
End Sub
Esta macro tiene como finalidad imprimir etiquetas, por eso me haría falta que me agrupase los resultados referentes a cada zona (columna nombre-kg) en una misma celda tal como viene en la imagen de ejemplo que adjunto en mi petición original. Me refiero a la línea del cliente con su peso
Hago correr la macro en una tabla con solo tres líneas y me da error en la línea que tengo en negrita. La hice correr con seis registros y ya no me da error, ¿a qué se debe?
For j = 1 To unicos.Count
zona = unicos.Item(j)
cuenta = WorksheetFunction.CountIf(.Columns(1), zona)
fila = WorksheetFunction.Match(zona, .Columns(1), 0)
With .Rows(fila).Resize(cuenta, 1)
Muchas gracias por la información.
Que error te aparece y pon una pantalla de esas tres líneas que mencionas he estado haciendo pruebas con la macro y a mi no me aparece ningún error
Aquí va una imagen de los datos que manipulo y pantallazo del error
En negrita tienes la linea que me da error en la macro
zona = unicos.Item(j)
cuenta = WorksheetFunction.CountIf(.Columns(1), zona)
fila = WorksheetFunction.Match(zona, .Columns(1), 0)
With .Rows(fila).Resize(cuenta, 1)
.ClearContents
.Merge
Tu macro crea una celda combinada para Norte (y así para cada resultado) y y luego concatena el nombre y los pesos colocándolos en celdas diferentes, yo pretendo que estén en la misma celda. Con el peso lo mismo. Adjunto imagen
Eso pasa cuando la información esta desordenada si pones norte, norte, sur te debe poner el resultado que quieres pero como no esta así por es te marca error, para evitar eso de dejo la pantalla con la solución solo inserta la línea marcada con la flecha y como puedes ver con esa línea se soluciona el problema
Ok. Solo una cosa en la imagen anterior los resultados correspondientes a cada registro de zona (norte, sur...) se agrupan en la siguiente columna de la derecha cada uno en una celda. Me haría falta que se agrupasen todos en una misma celda, es esto posible. Adjunto imagen
Esta macro hace lo que pides te deja toda la información de las zonas en una sola celda
Sub crea_tablas()
Application.DisplayAlerts = False
titulos = Array("zona", "nombre_kg", "total_kg")
Dim unicos As New Collection
Set datos = Range("a1").CurrentRegion
With datos
filas = .Rows.Count: columnas = .Columns.Count
With .Rows(filas + 3)
.CurrentRegion.ClearContents
.Resize(filas, columnas).UnMerge
datos.Copy
.Resize(filas, columnas).PasteSpecial xlValues
.CurrentRegion.Name = "zonas"
End With
With [zonas]
.Rows(1) = titulos
.Rows(1).Font.Bold = True
.Sort key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=xlYes
filas = .Rows.Count: columnas = .Columns.Count
For i = 2 To filas
zona = .Cells(i, 1)
On Error Resume Next
unicos.Add zona, CStr(zona)
On Error GoTo 0
Next i
For j = 1 To unicos.Count
zona = unicos.Item(j)
cuenta = WorksheetFunction.CountIf(.Columns(1), zona)
fila = WorksheetFunction.Match(zona, .Columns(1), 0)
.Rows(fila).Resize(cuenta).Name = "area"
With [area]
texto = Empty
For k = 1 To cuenta
If k = 1 Then texto = .Cells(k, 2) & " " & .Cells(k, 3)
If k > 1 Then texto = texto & vbLf & .Cells(k, 2) & " " & .Cells(k, 3)
Next k
.Cells(1, 2) = texto
.Cells(1, 3) = WorksheetFunction.Sum(.Columns(3))
.Columns(1).Merge
.Columns(2).Merge
.Columns(3).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next j
End With
End With
Application.DisplayAlerts = True
End Sub
