Skip to main content
Edición en en código adjuntado
Origen Enlace
    Private Sub cmdagacc_Click()

Set h1 = Sheets("MEMORIAS ACTO")    'Origen
Set h2 = Sheets("EMPALMES")         'Destino
'Set

Set R1 = h1.Range("CJ29")
'SetSet R2 = h1.Range("CJ87")
K = 29
Set R = h1.Range("CJ" & Rows.Count).End(xlUp).Row
N = "CJ" & K & ":A" & R
Evn = cbxtacc.Value
Dim rng As Range

If cbxtacc.Value = "" Or cbxtacc.ListIndex = -1 Then
    MsgBox "Seleccione un tipo de Accesorio"
    cbxtacc.SetFocus
    Exit Sub
End If

Existe = False

'Set rng = h1.Range("CJ29:CK87")
'SetDim rngR =As h1.Columns("CJ:CK")Object
Set b = h1.Range(N).Find(Evn, LookIn:=xlValues, LookAt"CJ29:=xlWhole)
'Set b = Sheets("MEMORIAS ACTO").Range("CJ29"CK87").Find(cbxtaccEvn, LookIn:=xlValues, LookAt:=xlWhole)

If Not b Is Nothing Then
    cl = b.Address
    
    Do
        Fila = b.Row + 1
        'kk = 2
        'ForFor j = Cells("CJ29").Cells To Columns("CK""CK87").Column
        For j = R1 To R2
            If h1.Cells(Fila, j).Value = cbxtacc.Value Then
                Existe = True
                Fila = Fila + 1
                k = k + 1
            Do While h1.Cells(Fila, j).Value <> ""
                h2.Cells(k, "B").Value = h1.Cells(Fila, j).Value
                h2.Cells(k, "C").Value = h1.Cells(Fila, j + 1).Value
                Fila = Fila + 1
                k = k + 1
            Loop
        Exit For
            End If
        Next

    Loop While Not b Is Nothing And b.Address <> cl
End If
    
If Existe = False Then
    MsgBox "Error al agregar los Accesorios", vbExclamation
Else
    MsgBox "Accesorios agregados", vbInformation
End If
       
Range("A1") = "Empalmes"

End Sub
Private Sub cmdagacc_Click()

Set h1 = Sheets("MEMORIAS ACTO")    'Origen
Set h2 = Sheets("EMPALMES")         'Destino
'Set R1 = h1.Range("CJ29")
'Set R2 = h1.Range("CJ87")
K = 29
Set R = h1.Range("CJ" & Rows.Count).End(xlUp).Row
N = "CJ" & K & ":A" & R
Evn = cbxtacc.Value
Dim rng As Range

If cbxtacc.Value = "" Or cbxtacc.ListIndex = -1 Then
    MsgBox "Seleccione un tipo de Accesorio"
    cbxtacc.SetFocus
    Exit Sub
End If

Existe = False

'Set rng = h1.Range("CJ29:CK87")
'Set rng = h1.Columns("CJ:CK")
Set b = h1.Range(N).Find(Evn, LookIn:=xlValues, LookAt:=xlWhole)
'Set b = Sheets("MEMORIAS ACTO").Range("CJ29").Find(cbxtacc, LookIn:=xlValues, LookAt:=xlWhole)

If Not b Is Nothing Then
    cl = b.Address
    
    Do
        Fila = b.Row + 1
        'k = 2
        'For j = Cells("CJ29").Cells To Columns("CK").Column
        For j = R1 To R2
            If h1.Cells(Fila, j).Value = cbxtacc.Value Then
                Existe = True
                Fila = Fila + 1
                k = k + 1
            Do While h1.Cells(Fila, j).Value <> ""
                h2.Cells(k, "B").Value = h1.Cells(Fila, j).Value
                h2.Cells(k, "C").Value = h1.Cells(Fila, j + 1).Value
                Fila = Fila + 1
                k = k + 1
            Loop
        Exit For
            End If
        Next

    Loop While Not b Is Nothing And b.Address <> cl
End If
    
If Existe = False Then
    MsgBox "Error al agregar los Accesorios", vbExclamation
Else
    MsgBox "Accesorios agregados", vbInformation
End If
       
Range("A1") = "Empalmes"

End Sub
    Private Sub cmdagacc_Click()

Set h1 = Sheets("MEMORIAS ACTO")    'Origen
Set h2 = Sheets("EMPALMES")         'Destino


Set R1 = h1.Range("CJ29")
Set R2 = h1.Range("CJ87")
Evn = cbxtacc.Value
Dim rng As Range

If cbxtacc.Value = "" Or cbxtacc.ListIndex = -1 Then
    MsgBox "Seleccione un tipo de Accesorio"
    cbxtacc.SetFocus
    Exit Sub
End If

Existe = False
Dim R As Object
Set b = h1.Range("CJ29:CK87").Find(Evn, LookIn:=xlValues, LookAt:=xlWhole)

If Not b Is Nothing Then
    cl = b.Address
    
    Do
        Fila = b.Row + 1
        k = 2
        For j = Cells("CJ29").Cells To Columns("CK87").Column
            If h1.Cells(Fila, j).Value = cbxtacc.Value Then
                Existe = True
                Fila = Fila + 1
                k = k + 1
            Do While h1.Cells(Fila, j).Value <> ""
                h2.Cells(k, "B").Value = h1.Cells(Fila, j).Value
                h2.Cells(k, "C").Value = h1.Cells(Fila, j + 1).Value
                Fila = Fila + 1
                k = k + 1
            Loop
        Exit For
            End If
        Next

    Loop While Not b Is Nothing And b.Address <> cl
End If
    
If Existe = False Then
    MsgBox "Error al agregar los Accesorios", vbExclamation
Else
    MsgBox "Accesorios agregados", vbInformation
End If
       
Range("A1") = "Empalmes"

End Sub
Origen Enlace

Como buscar datos y exportarlos a otra hoja de excel

actualmente estoy trabajando en un código el cuál debe:

1.

Leer el ítem que el usuario seleccione de un Combobox, por ejemplo:

introducir la descripción de la imagen aquí

  1. Ir a una hoja llamada "MEMORIAS ACTO" y hacer la búsqueda de dicho ítem, en las columnas "CJ" y "CK" (se hace en estas 2 columnas ya que los encabezados están en una celda combinada)

introducir la descripción de la imagen aquí

  1. Como pueden ver el ítem que se busca es el encabezado de unos cuadros, una vez que se encuentre el ítem que el usuario desea buscar se debe copiar los datos que le pertenecen a ese ítem y llevarlos a una hoja llamada "EMPALMES"

introducir la descripción de la imagen aquí

Se copian y como dije se llevan a la hoja "EMPALMES" y en dicha hoja se deben pegar lo elementos a partir de la celda B2, de la siguiente forma:

introducir la descripción de la imagen aquí

Les adjunto el código que yo misma hice para tratar de hacer todo lo anterior, pero el código no me funciona, siempre me sale o el error 13 (no coinciden los tipos) o el 404 (Se requiere un objeto)

Private Sub cmdagacc_Click()

Set h1 = Sheets("MEMORIAS ACTO")    'Origen
Set h2 = Sheets("EMPALMES")         'Destino
'Set R1 = h1.Range("CJ29")
'Set R2 = h1.Range("CJ87")
K = 29
Set R = h1.Range("CJ" & Rows.Count).End(xlUp).Row
N = "CJ" & K & ":A" & R
Evn = cbxtacc.Value
Dim rng As Range

If cbxtacc.Value = "" Or cbxtacc.ListIndex = -1 Then
    MsgBox "Seleccione un tipo de Accesorio"
    cbxtacc.SetFocus
    Exit Sub
End If

Existe = False

'Set rng = h1.Range("CJ29:CK87")
'Set rng = h1.Columns("CJ:CK")
Set b = h1.Range(N).Find(Evn, LookIn:=xlValues, LookAt:=xlWhole)
'Set b = Sheets("MEMORIAS ACTO").Range("CJ29").Find(cbxtacc, LookIn:=xlValues, LookAt:=xlWhole)

If Not b Is Nothing Then
    cl = b.Address
    
    Do
        Fila = b.Row + 1
        'k = 2
        'For j = Cells("CJ29").Cells To Columns("CK").Column
        For j = R1 To R2
            If h1.Cells(Fila, j).Value = cbxtacc.Value Then
                Existe = True
                Fila = Fila + 1
                k = k + 1
            Do While h1.Cells(Fila, j).Value <> ""
                h2.Cells(k, "B").Value = h1.Cells(Fila, j).Value
                h2.Cells(k, "C").Value = h1.Cells(Fila, j + 1).Value
                Fila = Fila + 1
                k = k + 1
            Loop
        Exit For
            End If
        Next

    Loop While Not b Is Nothing And b.Address <> cl
End If
    
If Existe = False Then
    MsgBox "Error al agregar los Accesorios", vbExclamation
Else
    MsgBox "Accesorios agregados", vbInformation
End If
       
Range("A1") = "Empalmes"

End Sub

Agradezco toda la ayuda que me puedan dar, y espero a ver logrado explicarme con claridad