Cambiar rango de una macro de excel que me hiciste
Buenas:
Ya sé que no estas disponible para excel pero lo tenia que intentar.
Hace un tiempo me hiciste una macro perfecta para crear una hoja resumen de varias hojas de un mismo libro. Las celdas resumidas eran todas de la misma fila. Ahora necesito hacer lo mismo pero con celdas que ocupen los rangos S3:AI6. Me podrías indicar como hacerlo?
He intentado modificar tu macro y soy incapaz.
Te la adjunto:
Private Sub CommandButton1_Click()
Dim i, NumHojas, NumHojaRes, Respuesta, CuentaColumnas As Integer
Dim HojaNueva As Sheets
Dim SeleccionVieja As Range
Set SeleccionVieja = Application.Selection
NumHojas = Sheets.Count
NumHojaRes = 0
For i = 1 To NumHojas
If LCase$(Sheets(i).Name) = "resumen" Then
NumHojaRes = i
Exit For
End If
Next
If NumHojaRes = 0 Then
Respuesta = MsgBox("No existe hoja resumen.La creo", vbYesNo + _
vbInformation, "Permiso para crear hoja resumen")
If Respuesta = vbYes Then
Sheets.Add(, Sheets(NumHojas)).Name = "Resumen"
NumHojas = NumHojas + 1
NumHojaRes = NumHojas
Else
Exit Sub
End If
End If
CuentaColumnas = 1
Application.ScreenUpdating = False
For i = 1 To NumHojas
If i <> NumHojaRes Then
Sheets(NumHojaRes).Cells(1, CuentaColumnas) = Sheets(i).Name
Sheets(i).Range("O3:O55").Copy
Sheets(NumHojaRes).Range(Cells(3, CuentaColumnas), _
Cells(55, CuentaColumnas)).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
CuentaColumnas = CuentaColumnas + 1
End If
Next
SeleccionVieja.Select
Set SeleccionVieja = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Muchas gracias por todo.
1 Respuesta
Es que se me estropeó el ordenador y no puedo repararlo por mi mismo. Ahora estoy con otro donde no tengo Office ni las macros que en su día fui creando. Por eso me es muy difícil poder contestar preguntas de Excel.
Por lo que veo esta macro tomaba los datos de la columna O3:O55 de cada hoja y hacia un resumen con tantas columnas como hojas.
Pero ahora los datos no están en una columna sino que ocupan varias columnas y 4 filas.
Entonces ¿Cómo quieres que se haga el resumen? Con las hojas puestas cada una al lado de la otra o con las hojas puestas una debajo de otra.
En todo caso haría la modificación pero no podría probarla, tendrías que hacerlo tú.
Efectivamente, los datos que antes estaban en una sola columna y los que necesito ahora ocupan 4 columnas y 17 filas s3:v19 (he cambiado el rango porque el de ayer no me servía).
Lo que me interesa es pegarlos uno debajo del otro, así luego podré hacer tablas dinámicas.
En la macro anterior, encima de cada columna aparecía el titulo de la hoja y ahora ya no me interesa porque necesito todo el bloque de datos. Si quitar los títulos cuesta mucho ya lo haré yo manualmente.
Como en la vez anterior, me interesa pegar el valor y el formato de las celdas, no la función.
Muchas gracias por todo.
Cambiaremos el rango de pegado y el lugar donde se pegan, aparte que quitar la orden de escribir el titulo de la hoja.
Supongo que quieres los datos pegados, sin líneas entre medio. De todas formas es muy sencillo dejar lineas en medio si quieres. También comenzare escribiendo datos en la fila 1 y columna pero se puede empezar en otra celda
Private Sub CommandButton1_Click()
Dim i, NumHojas, NumHojaRes, Respuesta, CuentaFilas As Integer
Dim HojaNueva As Sheets
Dim SeleccionVieja As Range
Set SeleccionVieja = Application.Selection
NumHojas = Sheets.Count
NumHojaRes = 0
For i = 1 To NumHojas
If LCase$(Sheets(i).Name) = "resumen" Then
NumHojaRes = i
Exit For
End If
Next
If NumHojaRes = 0 Then
Respuesta = MsgBox("No existe hoja resumen.La creo", vbYesNo + _
vbInformation, "Permiso para crear hoja resumen")
If Respuesta = vbYes Then
Sheets.Add(, Sheets(NumHojas)).Name = "Resumen"
NumHojas = NumHojas + 1
NumHojaRes = NumHojas
Else
Exit Sub
End If
End If
CuentaFilas = 1
Application.ScreenUpdating = False
For i = 1 To NumHojas
If i <> NumHojaRes Then
' QUITAMOS la linea siguiente comentando o borrándola directamente
' Sheets(NumHojaRes).Cells(1, CuentaColumnas) = Sheets(i).Name
Sheets(i). Range("S3:V19"). Copy
Sheets(NumHojaRes).Range(Cells(CuentaFilas,1), _
Cells(CuentaFilas+16,4)).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
CuentaFilas = CuentaFilas + 17
End If
Next
SeleccionVieja.Select
Set SeleccionVieja = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
En negrita he escrito las líneas que han cambiado algo. Pruébalo y si va mal o necesitas alguna modificación me lo dices.
