Agregar dos columnas a una macro que tiene seis
Tengo una macro creada por el Sr Dante Amor la cual pongo más abajo que me hace una transferencia de datos tomando los datos desde la columna A a la columna F. Necesito modificar esta macro para que me transpase también hasta la columna H
Ub PasarDatos()
'Por Dante Amor
Dim i As Long, j As Long, k As Long, n As Long, nmax As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range
'
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Respuestas de formulario 1")
Set sh2 = Sheets("Resumen por menu")
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
sh2.Rows("4:" & Rows.Count).Clear
'
k = 4
For Each c In sh1.Range("O2", sh1.Range("O" & Rows.Count).End(3))
nmax = 0
For j = 2 To Columns("F").Column 'ciclo de columnas de B a F
sh1.Range("A1:F" & sh1.Range("A" & Rows.Count).End(3).Row).AutoFilter j, c.Value & "*"
n = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If n > nmax Then nmax = n
If j = 2 Then
With sh2.Cells(k, j)
.Value = c.Value
.Resize(1, 5).HorizontalAlignment = xlCenter
.Resize(1, 5).MergeCells = True
End With
End If
sh2.Cells(k + 1, j).Value = n
sh1.AutoFilter.Range.Columns(1).Offset(1).Copy sh2.Cells(k + 2, j)
sh1.ShowAllData
Next
k = k + nmax + 2
Next
sh2.Range("B4:F" & k - 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub
1 respuesta
Te paso la macro actualizada:
Sub PasarDatos()
'Por Dante Amor
Dim i As Long, j As Long, k As Long, n As Long, nmax As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range
'
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Respuestas de formulario 1")
Set sh2 = Sheets("Resumen por menu")
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
sh2.Rows("4:" & Rows.Count).Clear
'
k = 4
For Each c In sh1.Range("O2", sh1.Range("O" & Rows.Count).End(3))
nmax = 0
For j = 2 To Columns("H").Column 'ciclo de columnas de B a H
sh1.Range("A1:H" & sh1.Range("A" & Rows.Count).End(3).Row).AutoFilter j, c.Value & "*"
n = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If n > nmax Then nmax = n
If j = 2 Then
With sh2.Cells(k, j)
.Value = c.Value
.Resize(1, 7).HorizontalAlignment = xlCenter
.Resize(1, 7).MergeCells = True
End With
End If
sh2.Cells(k + 1, j).Value = n
sh1.AutoFilter.Range.Columns(1).Offset(1).Copy sh2.Cells(k + 2, j)
sh1.ShowAllData
Next
k = k + nmax + 2
Next
sh2.Range("B4:H" & k - 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End SubNota: En lo sucesivo, cuando insertes código en este foro, utiliza el icono para "Insertar código fuente".
Presiona el icono y te aparecerá una ventana, ahí pega el código y presiona "OK".
De esa manera es más fácil leer el código, copiar el código y además respeta el formato de VBA.
¡Gracias! Cadia día mejora mi planilla gracias a ti. Y encima aprendo cosas
No olvides la valoración.
