¿Cómo copiar rangos de celdas de otra hoja mediante checkbox?
Tengo una hoja donde se encuentra una " plantilla " de unos productos, el problema que tengo que mediante este código que me funciona con los dos primeros checkbox y en el tercero tengo un error de objeto .
Private Sub CommandButton1_Click()
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
'Asignando Objetos de busqueda y hojas
'Asignando Objetos de busqueda y hojas
Set h1 = Sheets("Plan MP")
Set b = h1.Columns("B").Find(TextBox1, lookat:=xlWhole)
u1 = h1.Range("B" & Rows.Count).End(xlUp).Row + 1
u3 = h1.Range("B" & Rows.Count).End(xlUp).Row + 1
u2 = h1.Range("B" & Rows.Count).End(xlUp).Row + 1
u4 = h1.Range("B" & Rows.Count).End(xlUp).Row + 11
'Asignando condicional de validacion de codigo
If TextBox1.Value = Empty Or TextBox2 = Empty Or TextBox3 = Empty Then
MsgBox " Asegurese de rellenar todos los casilleros ", vbCritical, "ATENCION !"
Unload Me
ElseIf Not b Is Nothing Then
MsgBox " Este codigo ya esta registrado "
End If
'
If CheckBox1.Value = True Then
Hoja1.Range("B4:AZ7").Copy
h1.Range("B" & u1).PasteSpecial Paste:=xlValues
'
For i = 1 To 4
h1.Cells(u1, "B") = Me.TextBox1.Value
h1.Cells(u1, "B").Interior.Color = RGB(255, 255, 0)
h1.Cells(u1, "D") = Me.TextBox2.Value
h1.Cells(u1, "D").Interior.Color = RGB(255, 255, 0)
h1.Cells(u1, "F") = Me.TextBox3.Value
h1.Cells(u1, "F").Interior.Color = RGB(255, 255, 0)
u1 = u1 + 1
Next i
ElseIf CheckBox2.Value = True Then
Hoja1.Range("B8:AZ11").Copy
h1.Range("B" & u1).PasteSpecial Paste:=xlValues
For i = 1 To 5
h1.Cells(u1, "B") = Me.TextBox1.Value
h1.Cells(u1, "B").Interior.Color = RGB(255, 255, 0)
h1.Cells(u1, "D") = Me.TextBox2.Value
h1.Cells(u1, "D").Interior.Color = RGB(255, 255, 0)
h1.Cells(u1, "F") = Me.TextBox3.Value
h1.Cells(u1, "F").Interior.Color = RGB(255, 255, 0)
u1 = u1 + 1
Next i
ElseIf CheckBox3.Value = True Then
Hoja1.Range("B12:AZ16").Copy
h1.Range("B" & u2).PasteSpecial Paste:=xlValues
For i = 1 To 5
h1.Cells(u2, "B") = Me.TextBox1.Value
h1.Cells(u2, "B").Interior.Color = RGB(255, 255, 0)
h1.Cells(u2, "D") = Me.TextBox2.Value
h1.Cells(u2, "D").Interior.Color = RGB(255, 255, 0)
h1.Cells(u2, "F") = Me.TextBox3.Value
h1.Cells(u2, "F").Interior.Color = RGB(255, 255, 0)
u2 = u2 + 1
Next i
End If
'
CheckBox1.Value = False
Unload Me
Load MP
MP.Show
1 respuesta
Respuesta de Dante Amor
2
Si , fue error mio , ya funciona , el problema es que si lo coloco individualmente funciona , el problema es que si activo los 3 checkbox , para que copie un rango seguido de otro no me funciona :(
Dante Amor Hola, me ayudarías a resolver el problema que si marco los 3 checkbox que tengo configurados actualmente, solo me copia el primer checkbox
Te anexo el código actualizado, pon los 2 procedimientos dentro de tu userform
Private Sub CommandButton1_Click()
'---
' Act.Por.Dante Amor
'---
'Asignando Objetos de busqueda y hojas
Set h1 = Sheets("Plan MP")
Set b = h1.Columns("B").Find(TextBox1, lookat:=xlWhole)
'Asignando condicional de validacion de codigo
If TextBox1.Value = Empty Or TextBox2 = Empty Or TextBox3 = Empty Then
MsgBox " Asegurese de rellenar todos los casilleros ", vbCritical, "ATENCION !"
Exit Sub
End If
If Not b Is Nothing Then
MsgBox " Este codigo ya esta registrado "
End If
'
If CheckBox1.Value = True Then Call Copiar_Rango(h1, "B4:AZ7", 3)
If CheckBox2.Value = True Then Call Copiar_Rango(h1, "B8:AZ11", 3)
If CheckBox3.Value = True Then Call Copiar_Rango(h1, "B12:AZ16", 4)
'
CheckBox1.Value = False
Unload Me
Load mp
mp.Show
End Sub
'
Sub Copiar_Rango(h1, rango, n)
'---
' Por.Dante Amor
'---
Application.ScreenUpdating = False
Hoja1.Range(rango).Copy
u1 = h1.Range("B" & Rows.Count).End(xlUp).Row + 1
h1.Range("B" & u1).PasteSpecial Paste:=xlValues
'
h1.Range(h1.Cells(u1, "B"), h1.Cells(u1 + n, "B")) = Me.TextBox1.Value
h1.Range(h1.Cells(u1, "B"), h1.Cells(u1 + n, "B")).Interior.Color = RGB(255, 255, 0)
h1.Range(h1.Cells(u1, "D"), h1.Cells(u1 + n, "D")) = Me.TextBox2.Value
h1.Range(h1.Cells(u1, "D"), h1.Cells(u1 + n, "D")).Interior.Color = RGB(255, 255, 0)
h1.Range(h1.Cells(u1, "F"), h1.Cells(u1 + n, "F")) = Me.TextBox3.Value
h1.Range(h1.Cells(u1, "F"), h1.Cells(u1 + n, "F")).Interior.Color = RGB(255, 255, 0)
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
R ecuerda cambiar la valoración a la respuesta.
Sal u dos
