Macro de excel que guarde en varias hojas
Necesito crear una macro en excel que me guarde los datos que ingreso en la hoja 1, en las hojas 2, 3 y 4 segun criterios. Ejemplo:
En la HOJA 1 voy a crear un formulario de captura de datos de pacientes con sus datos principales y diagnostico, ocupo que los registros se me guarden en las diferentes hojas segun diagnostico_
NOMBRE: MARCO
IDENTIFICACION: 99999
EDAD: 39
Diagnostico: lumbalgia
EN LA HOJA 2. Ocupo que me guarde todos los registros que lleven el diagnostico LUMBALGIA
EN LA HOJA 3: Ocupo que me guarde todos los registros que lleven el diagnostico DENGUE
EN LA HOJA 4: Ocupo que me guarde todos los registros que lleven el diagnostico DIARREA
Mi correo es: [email protected]
2 Respuestas
H o l a
Te paso la macro, lo que elijas en el combo diagnóstico guardará en la hoja correspondiente.
aquí el código
Private Sub CommandButton1_Click()
If ComboBox1 = "" Or ComboBox1.ListIndex = -1 Then Exit Sub
Set h1 = Sheets(ComboBox1.ListIndex + 1)
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
h1.Cells(u, "A") = ComboBox1
h1.Cells(u, "B") = TextBox1
h1.Cells(u, "C") = Val(TextBox2)
h1.Cells(u, "D") = Val(TextBox3)
ComboBox1 = ""
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
h1.Select
MsgBox "Registrados correctamente", vbInformation
End Sub
Private Sub UserForm_Activate()
For Each hoja In Sheets
ComboBox1.AddItem hoja.Name
Next
End SubTe envié el archivo
Valora para finalizar Excelente o bueno saludos!
¡Gracias!
H o l a
Te faltó valorar Excelente o bueno
Ante todo encantado de ayudarte a ver si te puede valer este código.
Primero suponemos que el diagnostico que vas a poner a cada paciente va en una hoja de calculo con el mismo nombre y, por otro lado supongo que en una fila tienes los encabezados de cada lista.
Por otro lado supongo que el textbox del diagnostico se llama txtDiagnostico (o como se llame), te lo pongo para que te hagas una idea luego lo adaptas a tus necesidades.
Creamos un modulo y ponemos los siguiente:
Yo lo haría de la siguiente forma, si tienes cualquier duda me comentas:
Sub RegistrarPaciente
Application.ScreenUpdating = False 'desactivamos el parpadeo de pantalla
'Creamos bucle para recorrer todas las hojas del libro
For i = 1 To Worksheets.Count
'Si la hoja con el nombre del diagnostico en mayúsculas
'es igual que el nombre de la hoja en mayúsculas entonces
'esto lo hacemos porque se diferencia entre mayúsculas y minúsculas
If UCase(Sheets(i).Name) = UCase(txtdiagnostico).Value Then
'La activamos
Sheets(i). Activate
'Salimos del for
Exit For
Else 'Si no existe agregamos una hoja y le damos el nombre del diagnostico
Sheets.Add
ActiveSheet.Name = txtdiagnostico.Value
'Agregamos los títulos en la fila 1
'con el caption de las etiquetas del formulario
'en caso de tener los títulos en las celdas referenciar las celdas
Range("A1").Value = label1.Caption 'Nombre
Range("A2").Value = label1.Caption 'Identificacion
Range("A3").Value = label1.Caption 'Edad
Range("A4").Value = label1.Caption 'Diagnostico
' 'Si quieres copiar los títulos y pegarlos de una hoja a otra
' 'con el mismo formato te dejo este código para agregar
'
' 'Seleccinamos una hoja y seleccionamos los títulos
' Sheets("Nombre de la hoja"). Activate
' ActiveSheet.Range("A1").Select
' Range(Selection, Selection.End(xlToRight)).Select
'
' 'Los copiamos a la hoja que acabamos de crear
' Selection. Copy Sheets(txtdiagnostico. Value). Range("A1")
'
' 'vaciamos el portapapeles
' Application.CutCopyMode = False
'salimos del for
Exit For
End If
Next i
'Una vez fuera del for copiamos los datos
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Activate
ActiveCell.Value = Nombre 'textbox del nombre o celda donde tengas el nombre
ActiveCell.Offset(0, 1).Value = Identificacion 'textbox o celda de la identificacion
ActiveCell.Offset(0, 2).Value = edad ' textbox o celda de la edad
ActiveCell.Offset(0, 3).Value = Diagnostico 'textbox o celda del diagnostico
Sheets("Hoja1").Activate
ActiveSheet.Range("A1").Select
MsgBox "El paciente se ha registrado correctamente", vbInformation, "Paciente registrado"
Application.ScreenUpdating = True
End Sub