Agregar una nueva hoja más en este conjunto de macros
Agradezco su valiosa ayuda en este libro que tengo para sumar un porcentaje a los valores en determinada columna
Tal como menciono en el titulo; incluir a la macro, una nueva hoja más, llamada Tabla1
Además de hacer para lo que están programadas las macros agregar para una hoja más llamada Tabla1
Que la macro se ejecute sobre la hoja Tabla1 también tal como lo hace con Tabla2, que; en la hoja Tabla2 escribe el nombre del mes en la columna H, en la hoja Tabla1 escribirá el nombre del mes en la columna I
La Tabla 2 es interrumpida más o menos a la mitad y la hoja Tabla1 es corrida y puede ser variable su cantidad de líneas
Como se puede ver en el libro mismo
En Tabla2 los porcentajes a sumar actúan sobre la columna D y en la nueva hoja (Tabla1) será sobre las columnas B y C; en B 10% y en C 5%
Al abrir el libro por 1ª vez en el mes, coloca el nombre del mes en la columna H de la Tabla2 que haga lo mismo en la columna I de la Tabla1
El conjunto de macros involucradas que funciona solo para Tabla2
Private Sub Workbook_Open()
Dim UltFila As Integer
MESact = Format(Date, "mmmm-yyyy")
UltFila = Sheets("Tabla2").Range("h" & Rows.Count).End(xlUp).Row
If Sheets("Tabla2").Range("h" & UltFila) = MESact Then
Else
Sheets("Tabla2").Range("h" & UltFila + 1) = MESact
Call actualiza
End If
End Sub
Sub actualiza()
HOJA = "Tabla2"
Sheets(HOJA).Copy After:=Sheets(2)
ActiveSheet.Name = "Copia"
For I = 3 To 27
If I = 14 Or I = 15 Or I = 16 Or I = 17 Then
Else
VALOR = Sheets(HOJA).Cells(I, 4).Value
Sheets(HOJA).Cells(I, 4).Value = VALOR * 1.1
End If
Next I
Sheets(HOJA).Select
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wSheet As Worksheet
On Error Resume Next
Set wSheet = Sheets("Copia")
If wSheet Is Nothing Then
MsgBox ("La hoja Copia no existe")
Else 'Si existe la hoja Copia
MsgBox ("La hoja Copia existe para eliminar")
Sheets("Copia").Delete
End If
End Sub
1 Respuesta
Ahora sí quedó claro ;)
Te estoy devolviendo el libro. Ya tiene las hojas actualizadas una vez por lo que los importes han cambiado.
Te agregué un mensaje de confirmación antes de eliminar las copias. Si te parece innecesario (los mensajes también así me parecieron), comentame para que te desactive esas líneas.
Sdos.
Elsa
Estoy tratando de bajar el libro, supongo que es el mismo que te envíe sol ocon los cambios tuyos CREO.
Creo porque no he logrado bajarlo
Si, es tu libro con las macros arregladas.
Te las paso aquí mismo:
Private Sub Workbook_Open() 'se trabajará sobre 2 hojas
Dim UltFila As Integer
MESact = Format(Date, "mmmm-yyyy")
'Tabla1
filaUlt = Sheets("Tabla1").Range("I" & Rows.Count).End(xlUp).Row
If Sheets("Tabla1").Range("I" & filaUlt) <> MESact Then
Sheets("Tabla1").Range("I" & filaUlt + 1) = MESact
Call actualiza("Tabla1")
End If
'Tabla2
UltFila = Sheets("Tabla2").Range("H" & Rows.Count).End(xlUp).Row
If Sheets("Tabla2").Range("h" & UltFila) <> MESact Then
Sheets("Tabla2").Range("h" & UltFila + 1) = MESact
Call actualiza("Tabla2")
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wSheet As Worksheet
On Error Resume Next
'agregar todas las hojas en la matriz
hojas = Array("Tabla1", "Tabla2")
Application.DisplayAlerts = False 'evita el mensaje de alerta al eliminar
For y = LBound(hojas) To UBound(hojas)
nbreCopia = "Copia_" & hojas(y)
Set wSheet = Sheets(nbreCopia) 'verifica si se realizó la copia de esa hoja
If wSheet Is Nothing Then
MsgBox ("La hoja " & wSheet.Name & " no existe")
Else
'Si existe la hoja Copia se la elimina previa confirmación
sino = MsgBox("La hoja " & wSheet.Name & " existe. ¿Deseas eliminarla?", vbQuestion + vbYesNo, "Confirmar")
If sino = vbYes Then wSheet.Delete
End If
Next y
Application.DisplayAlerts = True
End SubY en un módulo la de la actualización:
Sub actualiza(HOJA)
Sheets(HOJA).Copy After:=Sheets(Sheets.Count) 'pueden ser más de 2 hojas la 2da vez
ActiveSheet.Name = "Copia_" & HOJA
'se incrementa en las hojas Tabla
Sheets(HOJA).Select
If HOJA = "Tabla2" Then
On Error Resume Next 'evita error al calcular textos
For I = 3 To 27
If I < 14 Or I > 17 Then 'solo se calcula en fila < 14 y > 17
VALOR = Cells(I, 4).Value
Cells(I, 4).Value = VALOR * 1.1
End If
Next I
Else
x = Range("A" & Rows.Count).End(xlUp).Row 'se establece el fin del rango
On Error Resume Next 'evita error al calcular textos
For I = 3 To x 'recorre la tabla hasta última fila ocupada
VALOR = Cells(I, 2).Value 'en columna B acumula el 10%
Cells(I, 2).Value = VALOR * 1.1
VALOR = Cells(I, 3).Value 'en columna C acumula el 5%
Cells(I, 3).Value = VALOR * 1.05
Next I
End If
MsgBox "Fin del proceso de actualización."
End SubSdos!
Se puede eliminar la colocación del mes en las hojas Copia_Tabla1 y 2 no hace falta en esas hojas pero si se puede quedaría más limpio, dejo a tu decisión
En la macro del módulo colocá estas instrucciones al inicio:
Sub actualiza(HOJA)
Sheets(HOJA).Copy After:=Sheets(Sheets.Count) 'pueden ser más de 2 hojas la 2da vez
ActiveSheet.Name = "Copia_" & HOJA
'quitar fechas de col I
If HOJA = "Tabla1" Then
Columns("I:I").Clear
Else
Columns("H:H").Clear
End If
'se incrementa en las hojas Tabla
'aquí sigue el resto del códigoEn esta misma macro quitale el mensaje que se encuentra antes del End Sub y esa misma instrucción colocala en el evento Open del libro, antes del End Sub:
MsgBox "Fin del proceso de actualización."
PD) Ahora sí creo que la valoración merece algo más que un 'Bueno' ;)
Sdos!
