Macro para copiar entradas únicas
Tengo una entrada de datos repetidos con una referencia única que a veces se repite.
Esa Hoja tiene columna A = estudio, columna B= refencia C= Nombre.
Me gustaría realizar una macro que en el momento que yo ingreso esa referencia única de la hoja 1 copie en otra hoja(2) la información de la referencia y nombre que yo he ingresado en la hoja 1, en la columna C y DE de la hoja 2.
Anteriormente realizar en la columna A contador numérico (1,2,3 a modo de registro) y en la columna B la fecha en que se entra ese dato.
Evidentemente en la hoja 1 a veces se repite la referencia dos y tres veces, es por ello que solo se necesitaría realizar la entrada en la hoja 2 la primera vez que se ingresa por primera vez la referencia en la hoja 1.
Todo ello a partir de una fila que yo asigne ya que ese registro que tengo necesito indexar a partir de ahora.
Tienes que pegar esta Macro en la Hoja1:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo fin
Dim resultado As Range
Dim valor As String
Dim rango As Range
Application.CutCopyMode = False
Application.ScreenUpdating = False
If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
If ActiveCell.Offset(-1, 1).Value = "" Then
nombre = InputBox("Ingrese el Nombre", vbOKOnly)
ActiveCell.Offset(-1, 1).Value = nombre
valor = ActiveCell.Offset(-1, 0).Value
celda = ActiveCell.Offset(-1, 0).Address
ActiveCell.Offset(-2, 0).Select
Range(ActiveCell, ActiveCell.End(xlUp)).Select
Else
valor = ActiveCell.Offset(-1, 0).Value
celda = ActiveCell.Offset(-1, 0).Address
ActiveCell.Offset(-2, 0).Select
Range(ActiveCell, ActiveCell.End(xlUp)).Select
End If
Set resultado = Selection.Cells.Find(What:=valor, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If resultado Is Nothing Then
ActiveCell.End(xlDown).Select
Range(ActiveCell, ActiveCell.Offset(0, 1)).Select
Selection.Copy
Sheets("Hoja2").Select
ActiveSheet.Range("C1").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.PasteSpecial xlValues
ActiveCell.Offset(0, -1).Value = Now
If Not IsNumeric(ActiveCell.Offset(-1, -2).Value) Then
ActiveCell.Offset(0, -2).Value = 1
Else
ActiveCell.Offset(0, -2).Value = ActiveCell.Offset(-1, -2).Value + 1
End If
Sheets("Hoja1").Select
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Else
ActiveCell.End(xlDown).Offset(1, 0).Select
End If
End If
Application.ScreenUpdating = True
fin:
End Sub
Te marco en negrita el valor que deberás cambiar por la celda a partir de la cual quieras que empiece a partir de ahora
Te dejo el archivo en dropbox or si no te funciona puedas compararlo
https://www.dropbox.com/s/da4ygiorrpd5c40/Entradas%20unicas.xlsm?dl=0
Ya me dirás
1 respuesta más de otro experto
H o l a : Para copiar los datos completos, tienes que capturar la Referencia y el Nombre, es decir, si capturas la Referencia, la macro no hace nada, si ya capturaste la Referencia y después capturas el Nombre, entonces la macro se activa y te copia los 2 datos a la hoja2; también puedes escribir primero el Nombre y después la Referencia, de igual manera, la macro se activará cuando los 2 datos estén capturados; de esa forma se copiarán los 2 datos a la hoja2.
En la macro, en esta línea: "If Target.Row < 10 Then Exit Sub", cambia el número 10 por el número de fila para empezar a indexar. Significa que si modificas datos en la fila 9 hacia abajo, esos datos no se copiarán a la hoja2.
Pon la siguiente macro en los eventos de tu hoja1:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Target.Row < 10 Then Exit Sub
If Not Intersect(Target, Range("B:C")) Is Nothing Then
If Cells(Target.Row, "B") = "" Or Cells(Target.Row, "C") = "" Then Exit Sub
'
Set h = Sheets("Hoja2")
Set b = h.Columns("C").Find(Cells(Target.Row, "B"), lookat:=xlWhole)
If b Is Nothing Then
u = h.Range("C" & Rows.Count).End(xlUp).Row + 1
h.Cells(u, "A") = h.Cells(u - 1, "A") + 1
h.Cells(u, "B") = Date
h.Cells(u, "C") = Cells(Target.Row, "B")
h.Cells(u, "D") = Cells(Target.Row, "C")
End If
End If
End SubSigue las Instrucciones para poner la macro en los eventos de worksheet
- Abre tu libro de excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- Del lado izquierdo dice: VBAProject, abajo dale doble click a worksheet(tu hoja)
- En el panel del lado derecho copia la macro
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Hola
No me acaba de funcionar totalmente ya que tengo una macro funcionando.
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.DAM
If Not Intersect(Target, Range("A:K")) Is Nothing Then
ActiveSheet.Unprotect "123"
Target.Locked = True
ActiveSheet.Protect "123"
End If
End Sub
Borra las macros y pon únicamente esta:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Target.Row < 10 Then Exit Sub
If Not Intersect(Target, Range("B:C")) Is Nothing Then
If Cells(Target.Row, "B") = "" Or Cells(Target.Row, "C") = "" Then Exit Sub
'
Set h = Sheets("Hoja2")
Set b = h.Columns("C").Find(Cells(Target.Row, "B"), lookat:=xlWhole)
If b Is Nothing Then
u = h.Range("C" & Rows.Count).End(xlUp).Row + 1
h.Cells(u, "A") = h.Cells(u - 1, "A") + 1
h.Cells(u, "B") = Date
h.Cells(u, "C") = Cells(Target.Row, "B")
h.Cells(u, "D") = Cells(Target.Row, "C")
End If
End If
'
If Not Intersect(Target, Range("A:K")) Is Nothing Then
ActiveSheet.Unprotect "123"
Target.Locked = True
ActiveSheet.Protect "123"
End If
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias