Sumatorias al final de las columnas..
Para DANTE AMOR!
Nuevamente molestándote, tengo una petición, dentro de mi archivo original tengo un formato en especifico en la parte de las sumatorias de algunas columnas, al momento de dar de alta o modificar algún registro por medio de mi form, se tendría que agregar esas operaciones.
Sería el mismo archivo de la pregunta anterior. "PROYECCIONES PROYECTOS."
El formato que deseo obtener esta en la Hoja2, en la parte inferior y este plasmarlo en la hoja1 que es donde se vacían los datos capturados en el formulario.
Respuesta de Dante Amor
1
Envíame un correo nuevo con el archivo, dentro del archivo me explicas con comentarios y con colores qué necesitas.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Gerardo Mujica Arevalo” y el título de esta pregunta.
Listo Dante, te mande el correo.
Buenas tardes Dante.
Tuve un problema personal y me ausente unos días. Una gran disculpa.
Prueba con lo siguiente y me comentas
'Alta de un registro
Private Sub CommandButton1_Click()
'Declaración de variables
'
Dim strTitulo As String
Dim Continuar As String
Dim TransRowRng As Range
Dim NewRow As Integer
Dim Limpiar As String
Dim xControl As Control
'
strTitulo = "PROYECCIONES"
'
If Me.ComboBox1_SUCURSAL = "" Then
Me.ComboBox1_SUCURSAL.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: SUCURSAL", , strTitulo
Me.ComboBox1_SUCURSAL.SetFocus
Exit Sub
ElseIf Me.txtCliente = "" Then
Me.txtCliente.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: CLIENTE", , strTitulo
Me.txtCliente.SetFocus
Exit Sub
ElseIf Me.ComboBox2_PMR = "" Then
Me.ComboBox2_PMR.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: TIPO DE PMR", , strTitulo
Me.ComboBox2_PMR.SetFocus
Exit Sub
ElseIf Me.txtCanal = "" Then
Me.txtCanal.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: CANAL", , strTitulo
Me.txtCanal.SetFocus
Exit Sub
ElseIf Me.txtNombrePrograma = "" Then
Me.txtNombrePrograma.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: NOMBRE DEL PROGRAMA", , strTitulo
Me.txtNombrePrograma.SetFocus
Exit Sub
ElseIf Me.txtNombreSAP = "" Then
Me.txtNombreSAP.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: NOMBRE EN SAP", , strTitulo
Me.txtNombreSAP.SetFocus
Exit Sub
ElseIf Me.ComboBox3_GDN = "" Then
Me.ComboBox3_GDN.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: GDN", , strTitulo
Me.ComboBox3_GDN.SetFocus
Exit Sub
ElseIf Me.ComboBox4_ESTATUS = "" Then
Me.ComboBox4_ESTATUS.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: ESTATUS", , strTitulo
Me.ComboBox4_ESTATUS.SetFocus
Exit Sub
ElseIf Me.ComboBox5_PROB = "" Then
Me.ComboBox5_PROB.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: PROBABILIDAD", , strTitulo
Me.ComboBox5_PROB.SetFocus
Exit Sub
ElseIf Me.txtFechaAlta = "" Then
Me.txtFechaAlta.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: FECHA DE ALTA EN ARCHIVO", , strTitulo
Me.txtFechaAlta.SetFocus
Exit Sub
ElseIf Me.txtArranque = "" Then
Me.txtArranque.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: ARRANQUE", , strTitulo
Me.txtArranque.SetFocus
Exit Sub
ElseIf Me.txtCicloAcumulacion = "" Then
Me.txtCicloAcumulacion.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: CICLO DE ACUMULACION DE PUNTOS", , strTitulo
Me.txtCicloAcumulacion.SetFocus
Exit Sub
ElseIf Me.txtValorContrato = "" Then
Me.txtValorContrato.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: VALOR DEL CONTRATO", , strTitulo
Me.txtValorContrato.SetFocus
Exit Sub
ElseIf Me.txtProyectado = "" Then
Me.txtProyectado.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: PROYECTADO", , strTitulo
Me.txtProyectado.SetFocus
Exit Sub
ElseIf Me.txtValorPunto = "" Then
Me.txtValorPunto.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: VALOR DEL PUNTO", , strTitulo
Me.txtValorPunto.SetFocus
Exit Sub
ElseIf Me.txtPuntosAcumulados = "" Then
Me.txtPuntosAcumulados.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: PUNTOS ACUMULADOS", , strTitulo
Me.txtPuntosAcumulados.SetFocus
Exit Sub
ElseIf Me.txtMontoenPesos = "" Then
Me.txtMontoenPesos.BackColor = &HC0C0FF
MsgBox "Debe rellenar el campo: MONTO EN PESOS", , strTitulo
Me.txtMontoenPesos.SetFocus
Exit Sub
End If
'For Each xControl In Me.Controls
' If xControl.Tag = "txt" And xControl = Empty Then
' xControl.BackColor = &HC0C0FF
' MsgBox "Debe rellenar el campo: " & UCase(xControl. ControlTipText), vbInformation, strTitulo
' xControl.SetFocus
' Exit Sub
' End If
'Next
Continuar = MsgBox("Dar de alta los datos?", vbYesNo + vbExclamation, strTitulo)
If Continuar = vbNo Then Exit Sub
'
cuenta = Application.WorksheetFunction.CountIf(Range("A:A"), txtID)
'
If cuenta > 0 Then
'
MsgBox "El ID '" & Me.txtID & "' ya se encuentra registrado", vbExclamation, strTitulo
'Para pasar los datos del formulario a la hoja
'cuenta = Me.txtID
'GoTo Continuar
'
Else
'
For Each celda In Range("N4:N1000")
If celda.Interior.Color = RGB(153, 0, 153) Then
'celda.Delete Shift:=xlUp
End If
Next celda
For Each celda In Range("O4:O1000")
If celda.Interior.Color = RGB(153, 0, 153) Then
'celda.Delete Shift:=xlDown
End If
Next celda
'
'Encontrar fila vacía al final de la tabla
i = 2
Set h1 = Sheets("Hoja1")
Do While h1.Cells(i, "A") <> ""
i = i + 1
Loop
h1.Rows(i).Insert
'Set TransRowRng = ThisWorkbook.Worksheets("Hoja1").Cells(4, 1).CurrentRegion
'NewRow = TransRowRng.Rows.Count + 1
NewRow = i
With ThisWorkbook.Worksheets("Hoja1")
.Cells(NewRow, 1).Value = Me.txtID.Value
.Cells(NewRow, 2).Value = Me.ComboBox1_SUCURSAL
.Cells(NewRow, 3).Value = Me.txtCliente
.Cells(NewRow, 4).Value = Me.ComboBox2_PMR
.Cells(NewRow, 5).Value = Me.txtCanal
.Cells(NewRow, 6).Value = Me.txtNombrePrograma
.Cells(NewRow, 7).Value = Me.txtNombreSAP
.Cells(NewRow, 8).Value = Me.ComboBox3_GDN
.Cells(NewRow, 9).Value = Me.ComboBox4_ESTATUS
.Cells(NewRow, 10).Value = Me.ComboBox5_PROB.Value
.Cells(NewRow, 11).Value = Me.txtFechaAlta
.Cells(NewRow, 12).Value = Me.txtArranque
.Cells(NewRow, 13).Value = Me.txtCicloAcumulacion
.Cells(NewRow, 14).Value = Me.txtValorContrato.Value
.Cells(NewRow, 15).Value = Me.txtProyectado.Value
.Cells(NewRow, 16).Value = Me.txtValorPunto.Value
.Cells(NewRow, 17).Value = Me.txtPuntosAcumulados.Value
.Cells(NewRow, 18).Value = Me.txtMontoenPesos.Value
'PROYECCIONES
.Cells(NewRow, 19).Value = Me.txtProyEne.Value
.Cells(NewRow, 20).Value = Me.txtVntEne.Value
.Cells(NewRow, 21).Value = Me.txtProyFeb.Value
.Cells(NewRow, 22).Value = Me.txtVntRealFeb.Value
.Cells(NewRow, 23).Value = Me.txtProyMarzo.Value
.Cells(NewRow, 24).Value = Me.txtVntRealMarzo.Value
.Cells(NewRow, 25).Value = Me.txtProyAbril.Value
.Cells(NewRow, 26).Value = Me.txtVntRealAbril.Value
.Cells(NewRow, 27).Value = Me.txtProyMayo.Value
.Cells(NewRow, 28).Value = Me.txtVntRealMayo.Value
.Cells(NewRow, 29).Value = Me.txtProyJunio.Value
.Cells(NewRow, 30).Value = Me.txtVntRealJunio.Value
.Cells(NewRow, 31).Value = Me.txtProyJulio.Value
.Cells(NewRow, 32).Value = Me.txtVntRealJulio.Value
.Cells(NewRow, 33).Value = Me.txtProyAgosto.Value
.Cells(NewRow, 34).Value = Me.txtVntRealAgosto.Value
.Cells(NewRow, 35).Value = Me.txtProySept.Value
.Cells(NewRow, 36).Value = Me.txtVntRealSept.Value
.Cells(NewRow, 37).Value = Me.txtProyOct.Value
.Cells(NewRow, 38).Value = Me.txtVntRealOct.Value
.Cells(NewRow, 39).Value = Me.txtProyNov.Value
.Cells(NewRow, 40).Value = Me.txtVntRealNov.Value
.Cells(NewRow, 41).Value = Me.txtProyDic.Value
.Cells(NewRow, 42).Value = Me.txtVntRealDic.Value
'
End With
For i = 1 To Range("I" & Rows.Count).End(xlUp).Row
If Cells(i, "I") = "TERMINADO" Then
Range(Cells(i, "A"), Cells(i, "AP")).Interior.ColorIndex = 15
Else
'Range(Cells(i, "A"), Cells(i, "AP")).Interior.ColorIndex = xlNone
End If
Next
MsgBox "Alta exitosa.", vbInformation, strTitulo
Dim Fila As Long
Fila = Range("A" & Rows.Count).End(xlUp).Row + 2
Rows(Fila).Font.Bold = True
Range("N" & Fila).Formula = "=SUM(N4:N" & Fila - 2 & ")"
Range("O" & Fila).Formula = "=SUM(O4:O" & Fila - 2 & ")"
Range("Q" & Fila).Font.Size = 8
Range("Q" & Fila) = "OTROS PEDIDOS PMR"
Range("N" & Fila).Interior.Color = RGB(153, 0, 153)
Range("O" & Fila).Interior.Color = RGB(153, 0, 153)
Range("N" & Fila).Font.ColorIndex = 2
Range("O" & Fila).Font.ColorIndex = 2
'
'FILA NUEVA
Dim Fila1, Fila2 As Long
Fila1 = Range("A" & Rows.Count).End(xlUp).Row + 3
Fila2 = Range("A" & Rows.Count).End(xlUp).Row + 4
Rows(Fila1).Font.Bold = True
Range("Q" & Fila1).Value = "TOTAL"
Range("Q" & Fila2).Value = "PRESUPUESTO PMR 2017"
Unload Me
End If
End SubNo entiendo para que borras la celda con esta instrucción:
celda.Delete Shift:=xlUp
Así que comenté esa celda, porque al borrar de esa forma también desplazas las fórmulas, a lo mejor solamente tienes que limpiar la celda, por ejemplo:
celda.clearcontents
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
