Copiar 2 rangos en otra hoja

Ante todo muchas gracias.
Estuve buscando bastante en la página pero no logro encontrar nada que se asemeje a mi problema.
Necesito pasar dos rangos de una hoja "BASE" (B13:B37 y F13:F37)
a otra hoja "ENTREGA" en los rangos (A5:A... Y C5:C...) respectivamente, pero sin que se borren los datos anteriores, agregándolos al final.

1 Respuesta

Respuesta
1
Si no te he entendido mal, este podría ser el código que necesitas. Cópialo a un módulo de tu hoja de cálculo y lo puedes ejecutar como una macro.
Un saludo
Option Explicit
Sub copiarLineasDeBaseEnEntrega()
    Dim nLinIni As Long
    Dim nLinFin As Long
    Dim ultimaLineaEntrega As Long
    Dim i As Long   ' Número de línea origen en la página base
    Dim n As Long   ' Número de línea destino en la página entrega
    ' Primero comprobamos que existan las páginas BASE y ENTREGA
    If Not existePagina("ENTREGA") Then Exit Sub
    If Not existePagina("BASE") Then Exit Sub
    ' Leemos el número de línea inicial y final a copiar
    Do
        nLinIni = leeNumeroLinea("Inicial")
        If nLinIni = 0 Then Exit Sub
        nLinFin = leeNumeroLinea("Final")
        If nLinFin = 0 Then Exit Sub
        If nLinFin < nLinIni Then
            MsgBox "Error: el número de línea final es menor que el inicial"
          Else
            Exit Do
        End If
    Loop
    ' Buscamos el último número de línea usado en la página "Entrega"
    ultimaLineaEntrega = buscaUltimaLineaUsadaEnEntrega()
    If ultimaLineaEntrega < 0 Then Exit Sub
    ' Ya sabemos cual es la línea inicial a copiar, la final y a partir de dónde
' tenemos que copiar. Copiamos los datos
    For i = nLinIni To nLinFin
        n = ultimaLineaEntrega + i - nLinIni + 1 ' Línea en la que copiamos el dato
        ' Copiamos de Base! Bi (columna 2) a Entrega! An (columna 1)
        Sheets("ENTREGA"). Cells(i, 1) = Sheets("BASE"). Cells(i, 2)
        ' Copiamos de Base!Fi (columna 6) a Entrega! Con (columna 3)
        Sheets("ENTREGA"). Cells(i, 6) = Sheets("BASE"). Cells(i, 3)
    Next i
    ' Ya está todo. Damos un mensaje y se terminó
    MsgBox "Datos copiados correctamente"
End Sub
Private Function existePagina(ByVal nomPagina As String) As Boolean
    Dim i As Integer
    On Error Resume Next
    i = Sheets(nomPagina).Index
    If Err = 0 Then
        existePagina = True
      Else
        existePagina = False
        MsgBox "ERROR: No existe la página '" & nomPagina & "'. Proceso cancelado"
    End If
    On Error GoTo 0
End Function
Private Function leeNumeroLinea(ByVal txtIniFin As String) As Long
    Dim aux As String
    Dim n As Long
    leeNumeroLinea = 0
    Do
        aux = InputBox("Número de línea " & txtIniFin, "Copiar de Base a Entrega", aux)
        If aux = "" Then Exit Function
        If IsNumeric(aux) Then ' Se ha tecleado un valor numérico
            If Val(aux) = CDbl(aux) Then ' Es un valor entero
                n = Int(aux)
                If n > 0 And n < 65536 Then
                    leeNumeroLinea = n
                    Exit Function
                End If
            End If
        End If
        MsgBox "El valor tecleado no es un número o contiene " & _
               "decimales o no está entre 1 y 65535"
    Loop
End Function
Private Function buscaUltimaLineaUsadaEnEntrega() As Long
    Dim i As Long
    ' Buscamos la última línea escrita.
    ' Para ello, primero buscamos una línea en blanco...
    i = 1
    Do While Sheets("ENTREGA").Cells(i, 1) <> ""
        i = i + 50
    Loop
    ' Y volvemos hacia atrás para buscar la última escrita
    Do While Sheets("ENTREGA").Cells(i, 1) = ""
        i = i - 1
        If i = 0 Then Exit Do
    Loop
    buscaUltimaLineaUsadaEnEntrega = i
End Function
Muchísimas gracias por tu respuesta.
No logro entender del todo esta macro. Solamente necesito copiar (B13:B37;F13:F37) de la hoja base a la hoja entrega.
La hoja base es una factura y entrega es un resumen con los productos y cantidades, yo lo vengo pasando manualmente pero necesito esto para ahorrar tiempo
http://www.fileden.com/files/2009/6/15/2477975/Vincular.zip
Esta es mi factura un poco resumida para que veas cual es la cuestión
patricio
He modificado un poco el código. Prueba mejor con este porque creo que es lo que buscas.
Por cierto, quizás te interese copiar más columnas además de la B y la F. Con duplicar las líneas "Sheets("ENTREGA").Cells(i, 1) = Sheets("BASE").Cells(i, 2)" lo puedes hacer.
Un saludo
Option Explicit
Sub copiarLineasDeBaseEnEntrega()
    Dim nLinIni As Long
    Dim nLinFin As Long
    Dim ultimaLineaEntrega As Long
    Dim i As Long   ' Número de línea origen en la página base
    Dim n As Long   ' Número de línea destino en la página entrega
    ' Primero comprobamos que existan las páginas BASE y ENTREGA
    If Not existePagina("ENTREGA") Then Exit Sub
    If Not existePagina("BASE") Then Exit Sub
'    ' Leemos el número de línea inicial y final a copiar
'    Do
'        nLinIni = leeNumeroLinea("Inicial")
'        If nLinIni = 0 Then Exit Sub
'        nLinFin = leeNumeroLinea("Final")
'        If nLinFin = 0 Then Exit Sub
'        If nLinFin < nLinIni Then
'            MsgBox "Error: el número de línea final es menor que el inicial"
'          Else
'            Exit Do
'        End If
'    Loop
    ' Ponemos fijos los números de línea inicial y final
    nLinIni = 13
    nLinFin = 37
    ' Buscamos el último número de línea usado en la página "Entrega"
    ultimaLineaEntrega = buscaUltimaLineaUsadaEnEntrega()
    If ultimaLineaEntrega < 0 Then Exit Sub
    ' Ya sabemos cual es la línea inicial a copiar, la final y a partir de dónde
' tenemos que copiar. Copiamos los datos
    n = ultimaLineaEntrega
    For i = nLinIni To nLinFin
        If Sheets("BASE").Cells(i, 2) <> "" Or Sheets("BASE").Cells(i, 3) <> "" Then
            ' Si hay algo en la línea de la página BASE lo copiamos
            n = n + 1 ' Línea en la que copiamos el dato
            ' Copiamos de Base!Bi (columna 2) a Entrega!An (columna 1)
            Sheets("ENTREGA").Cells(i, 1) = Sheets("BASE").Cells(i, 2)
            ' Copiamos de Base!Fi (columna 6) a Entrega!Cn (columna 3)
            Sheets("ENTREGA").Cells(i, 6) = Sheets("BASE").Cells(i, 3)
        End If
    Next i
    ' Ya está todo. Damos un mensaje y se terminó
    MsgBox "Datos copiados correctamente"
End Sub
Private Function existePagina(ByVal nomPagina As String) As Boolean
    Dim i As Integer
    On Error Resume Next
    i = Sheets(nomPagina).Index
    If Err = 0 Then
        existePagina = True
      Else
        existePagina = False
        MsgBox "ERROR: No existe la página '" & nomPagina & "'. Proceso cancelado"
    End If
    On Error GoTo 0
End Function
Private Function leeNumeroLinea(ByVal txtIniFin As String) As Long
    Dim aux As String
    Dim n As Long
    leeNumeroLinea = 0
    Do
        aux = InputBox("Número de línea " & txtIniFin, "Copiar de Base a Entrega", aux)
        If aux = "" Then Exit Function
        If IsNumeric(aux) Then ' Se ha tecleado un valor numérico
            If Val(aux) = CDbl(aux) Then ' Es un valor entero
                n = Int(aux)
                If n > 0 And n < 65536 Then
                    leeNumeroLinea = n
                    Exit Function
                End If
            End If
        End If
        MsgBox "El valor tecleado no es un número o contiene " & _
               "decimales o no está entre 1 y 65535"
    Loop
End Function
Private Function buscaUltimaLineaUsadaEnEntrega() As Long
    Dim i As Long
    ' Buscamos la última línea escrita.
    ' Para ello, primero buscamos una línea en blanco...
    i = 1
    Do While Sheets("ENTREGA").Cells(i, 1) <> ""
        i = i + 50
    Loop
    ' Y volvemos hacia atrás para buscar la última escrita
    Do While Sheets("ENTREGA").Cells(i, 1) = ""
        i = i - 1
        If i = 0 Then Exit Do
    Loop
    buscaUltimaLineaUsadaEnEntrega = i
End Function

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Almacenar los datos de una celda

Antes de explicarme me gustaría agradecer a todos los que hacéis posible esta página, ya que nos sirve de mucho vuestro trabajo, gracias. Bueno lo que intento es hacer en una celda de una hoja en la que voy a meter muchos DNI, almacenarlos en otra...
1 respuesta

Ayuda VLOOKUP usado con VBA

Tengo el siguiente código en un modulo Sub buscar() On Error GoTo ERROR2: '=================================== Reporte de linea 501 Reporte.Range("C6") = Application.WorksheetFunction.VLookup(Reporte.Range("B2"), L501.Range("A3:R4500"), 2, False)...
1 respuesta

Macro para copiar celdas

Necesito una macro que me copie los datos de la celda B5 de la hoja 1 a la celda A2 de la hoja 2 lo que pasa es que los datos de la celda B5 me van cambiando y quiero que todos los datos se me vallan guardando en la celda A2, A3, A4, ... En fin en...
1 respuesta

Png en un form de visual basic

Ya se q se se respondio a esta pregunta, diciendo q habia q entrar a proyecto | referencias y ahi se tenia q buscar: paintx.dll ... Solo q cuando yo lo hice no encontre "paint.dll" asi q me lo descargue de http://www.paintlib.de/paintlib/ (nose si...
1 respuesta

Como ejecutar macro una sola vez

Quisiera que uno de los códigos de mi libro excel se ejecute al abrir el libro, pero solo la primera vez que se abra el libro; osea, que la segunda vez que yo abra este libro, la macro ya no se ejecute. Pero si este libro se abre en otro pc se vuelva...
1 respuesta

Macros para buscar cadena de texto

Estoy haciendo una macros para buscar datos de una columna y después pegar toda la fila a otra celda, todo dentro de la misma hoja, quiero modificar el código para que el resultado lo pegue en otra hoja pero no me resulta, por favor si alguien me...
1 respuesta

¿Cómo manejar (copiar y pegar) archivos externos desde una Macro VBA?

Tengo una carpeta-A con miles de archivos, y una hoja de Excel con los nombres de algunos de ellos. Quiero desde la Macro, buscar cada uno de ellos, copiarlo y pegarlo en una carpeta-B.
1 respuesta