Macro para trasladar de una hoja a otra datos de celdas
Para Dante Amor: hola Dante, necesito mejorar mi macro, te paso el archivo lo que quiero hacer es cuando cargo en la hoja ppal un problema, agregarle una acción y fecha (hoy solo agrega acción) asociarle una verificación con casilla y que todo eso pase a la hoja Acción y quede como una base de datos con su "problema" "acciòn" "verificaciòn" "fecha" me gustaría luego agregarle responsable también.
1 Respuesta
Respuesta de Dante Amor
3
Envíame tu archivo
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Nicolas Koroll” y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado. 
S a l u d o s . D a n t e A m o r
Te anexo las macros actualizadas
Sub AddProject()
Dim r As Single
If Range("B7") <> "" Then
r = Worksheets("problema").Range("A" & Rows.Count).End(xlUp).Row + 1
Worksheets("problema").Range("A" & r) = Range("B7").Value
Range("B3").Value = Range("B7").Value
Range("B7").Value = ""
Range("D3").Select
End If
End Sub
Sub AddAction()
Dim r As Single
Application.ScreenUpdating = False
If Range("D3") <> "" Then
r = Worksheets("Acción").Range("A" & Rows.Count).End(xlUp).Row + 1
If IsNumeric(Worksheets("Acción").Range("A" & r - 1)) Then
Worksheets("Acción").Range("A" & r) = Worksheets("Acción").Range("A" & r - 1) + 1
Else
Worksheets("Acción").Range("A" & r) = 1
End If
Worksheets("Acción").Range("B" & r) = Range("B3").Value
Worksheets("Acción").Range("C" & r) = Range("D3").Value
'Se agrega la fecha .DAM
Worksheets("Acción").Range("E" & r) = Range("E3").Value
Range("D3").Value = ""
End If
Range("D3").Select
Call RefreshList
Application.ScreenUpdating = True
End Sub
'
Sub Addfecha()
' Dim r As Single
' Application.ScreenUpdating = False
' If Range("E3") <> "" Then
' r = Worksheets("Acción").Range("A" & Rows.Count).End(xlUp).Row + 1
' If IsNumeric(Worksheets("Acción").Range("A" & r - 1)) Then
' Worksheets("Acción").Range("A" & r) = Worksheets("Acción").Range("A" & r - 1) + 1
' Else
' Worksheets("Acción").Range("A" & r) = 1
' End If
' Worksheets("Acción").Range("B" & r) = Range("B3").Value
' Worksheets("Acción").Range("e" & r) = Range("e3").Value
' Range("e3").Value = ""
' End If
' Range("e3").Select
' Application.ScreenUpdating = True
Set h1 = Sheets("ppal")
Set h2 = Sheets("Acción")
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
If h2.Cells(i, "B") = h1.Range("B3") Then
h2.Cells(i, "E") = h1.Range("E3")
End If
Next
Call RefreshList
Range("E3").Value = ""
End Sub
'
Sub RefreshList()
Dim rA, rO As Single
Dim Rng As Range
Dim CLeft, CTop, CHeight, CWidth As Double
Application.ScreenUpdating = False
Set Rng = Selection
'Cambiar hasta F para limpiar las celdas .DAM
Range("D7:F" & Rows.Count) = ""
rA = Worksheets("Acción").Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.CheckBoxes.Delete
If Range("B3").Value <> "" And rA > 1 Then
Do
If Worksheets("Acción").Range("B" & rA) = Range("B3").Value Then
rO = Worksheets("ppal").Range("D" & Rows.Count).End(xlUp).Row + 1
Worksheets("ppal").Range("D" & rO) = Worksheets("Acción").Range("C" & rA).Value
'se agrega la fecha en F .DAM
Worksheets("ppal").Range("F" & rO) = Worksheets("Acción").Range("E" & rA).Value
CLeft = Cells(rO, "E").Left
CTop = Cells(rO, "E").Top
CHeight = Cells(rO, "E").Height
CWidth = Cells(rO, "E").Width
ActiveSheet.CheckBoxes.Add(CLeft + CWidth / 2 - 8, CTop, CWidth, CHeight).Select
With Selection
.Caption = ""
If Worksheets("Acción").Range("D" & rA).Value = 1 Then
.Value = 1
Else
.Value = xlOff
End If
.Display3DShading = False
End With
End If
rA = rA - 1
Loop Until rA = 1
End If
Rng.Select
Application.ScreenUpdating = True
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
