Buenas tardes a todos, necesito una ayuda para copiar un rango de filas  de una hoja a un archivo externo(Base de Datos), la situacion es la siguiente:

1. Un archivo tiene varias hojas, numeradas del 1 al 30, que son los dias del mes, en este caso el ejemplo es 1,2.

2. En cada hoja hay unas filas, o sea registros del dia, estan de la fila 500 hasta máximo la fila 649, pueden ser menores, o sea, un dia puede ser de la 500 a la 510, otro de la 500 a la 520, así sucesivamente.

3. Estos registros los debo copiar a Una Base de Datos Externa, o sea, adicionarlos dia a dia, es decir buscar el ultimo registro de la base de datos externa y copiarlos al final.

4. Lo deseo hacer por una Macro

 

Lo he intentado y no me sale siguiendo el procedimiento de crear una macro automática.

 

Les agradeceria si pudieran colaborarme.

 

Adiciono un ejemplo de dos dias con unos datos de prueba, no coloco la Base de Datos para ver como se puede crear desde cero.

 

Agradeciéndoles la colaboración

 

Prueba Copia de Registros sin Filas en Blanco.xlsm

Dr. Hyde, buenas tardes

Realice otra prueba, fue la siguiente:

1. Copie los datos que tenemos en el archivo  ("Prueba Copia de Registros sin Filas en Blanco (2)")  al archivo original donde tengo los días.

2. Ejecute el Botón Resumir y funciona.

3. Según esto el formato del copiar las filas tiene algo que ver?

Gracias

 

Dr. Hyde, disculpe por tanta molestia, pero de tanto hacer pruebas, borrar y volver a colocar todo, volvi a ejecutar y si funciono, me copio los registros, que FELICIDAD, usted si sabe de esto, ojala pudiera aprender de esa manera

Pero como siempre una pregunta, al copiar los datos en la Base de Datos, porque no respeta el formato de los campos de la  de la Base de Datos?

1. Le envío copia como me quedan los datos en la Base de datos, son los 3 últimos.

2. Las dos Macros como quedaron asi, o sera que se pueden realizar en un solo Botón?

PRIMERA MACRO - BOTON DE COPIAR REGISTROS DONDE NO HAYA FILAS EN BLANCO.

Option Base 1
Sub copiar()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
' Empieza el traslado de los registros sin filas en blanco
Set datos = Range("a320").CurrentRegion
Set datos = datos.Rows(1).Resize(149, datos.Columns.Count)

Set origen = datos.Offset(1, 0).Resize(datos.Rows.Count - 1, datos.Columns.Count)
Range("a500").Resize(origen.Rows.Count, origen.Columns.Count).ClearContents
Set destino = Range("a500").Resize(origen.Rows.Count, origen.Columns.Count)
ReDim matriz(datos.Rows.Count, datos.Columns.Count)

a = 1
For Each Fila In origen.Rows
    fil = Fila.Row - origen.Row + 1
    f = Fila
    If f(1, 4) = Empty Then GoTo siguiente
    
    For i = 1 To origen.Columns.Count
        matriz(a, i) = f(1, i)
    Next i
    a = a + 1
siguiente:
Next Fila

Range(destino.Address) = matriz
origen.Rows(0).Copy destino.Rows(0)
'destino.Select
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

SEGUNDA MAGRO - BOTON COPIAR REGISTROS DE UNA HOJA A LA BASE DE DATOS EXTERNA

Sub copia2()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
Set hd = Workbooks("0. Base_Datos_Acumulada.xlsm")
Set destino = hd.ActiveSheet.Range("a1").CurrentRegion

Set ho = ActiveWorkbook
Set origen = ho.ActiveSheet.Range("a500").CurrentRegion

c = origen.Rows(1).Interior.ColorIndex

If c = 15 Then
    Set origen = origen.Rows(2).Resize(origen.Rows.Count - 1, origen.Columns.Count)
End If

origen.Copy destino.Rows(destino.Rows.Count + 1)
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

No tengo palabras para agradecerle todo lo que me ha aguantado, he aprendido, pero cada vez veo que se menos.

 

Muchas gracias y mil gracias.

 

0. Base_Datos_Acumulada - copia.xlsm

Dr. Hyde, buenos días

Lastima le escribí anoche informando que ya me funciona, pero queria perfeccionarlo, no se porque no paso el correo. 

1. Relaciono Macro Copiar Registros sin filas en Blanco 

• Nombre del Boton o Macro: "Copiar"

Sub copiar()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
' Empieza el traslado de los registros sin filas en blanco
Set datos = Range("a320").CurrentRegion
Set datos = datos.Rows(1).Resize(149, datos.Columns.Count)

Set origen = datos.Offset(1, 0).Resize(datos.Rows.Count - 1, datos.Columns.Count)
Range("a500").Resize(origen.Rows.Count, origen.Columns.Count).ClearContents
Set destino = Range("a500").Resize(origen.Rows.Count, origen.Columns.Count)
ReDim matriz(datos.Rows.Count, datos.Columns.Count)

a = 1
For Each Fila In origen.Rows
    fil = Fila.Row - origen.Row + 1
    f = Fila
    If f(1, 4) = Empty Then GoTo siguiente
    
    For i = 1 To origen.Columns.Count
        matriz(a, i) = f(1, i)
    Next i
    a = a + 1
siguiente:
Next Fila

Range(destino.Address) = matriz
origen.Rows(0).Copy destino.Rows(0)
'destino.Select
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

2. Relaciono Macro que Copia Registros de una hoja a un archivo Externo

• Nombre del Boton o Macro: "Copiar2"

Sub copia2()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
Set hd = Workbooks("0. Base_Datos_Acumulada.xlsm")
Set destino = hd.ActiveSheet.Range("a1").CurrentRegion

Set ho = ActiveWorkbook
Set origen = ho.ActiveSheet.Range("a500").CurrentRegion

c = origen.Rows(1).Interior.ColorIndex

If c = 15 Then
    Set origen = origen.Rows(2).Resize(origen.Rows.Count - 1, origen.Columns.Count)
End If

origen.Copy destino.Rows(destino.Rows.Count + 1)
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

3. Porque cuando copia los registros al archivo de la Base de datos o cuando ejecuta la primera macro no que copia los registros sin filas en blanco, no los copia con el formato?

• Adjunto Archivo de muestra, son los últimos tres registros, que no quedan con el formato de la Base de Datos.

 

Nuevamente no tengo sino palabras de agradecimiento y de saber como me puedo capacitar, ojala aprendiendo por lo menos del 10% que usted sabe, para entender el manejo de todas estas rutinas, macros, instrucciones, etc...

0. Base_Datos_Acumulada - copia.xlsm

Dr. Hyde, que pena, veo que si paso el correo, esta repetido, disculpe.

Hace 20 horas, Oscar Arroyave dijo:

Dr. Hyde, disculpe por tanta molestia, pero de tanto hacer pruebas, borrar y volver a colocar todo, volvi a ejecutar y si funciono, me copio los registros, que FELICIDAD, usted si sabe de esto, ojala pudiera aprender de esa manera

Pero como siempre una pregunta, al copiar los datos en la Base de Datos, porque no respeta el formato de los campos de la  de la Base de Datos?

1. Le envío copia como me quedan los datos en la Base de datos, son los 3 últimos.

2. Las dos Macros como quedaron asi, o sera que se pueden realizar en un solo Botón?

PRIMERA MACRO - BOTON DE COPIAR REGISTROS DONDE NO HAYA FILAS EN BLANCO.

Option Base 1
Sub copiar()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
' Empieza el traslado de los registros sin filas en blanco
Set datos = Range("a320").CurrentRegion
Set datos = datos.Rows(1).Resize(149, datos.Columns.Count)

Set origen = datos.Offset(1, 0).Resize(datos.Rows.Count - 1, datos.Columns.Count)
Range("a500").Resize(origen.Rows.Count, origen.Columns.Count).ClearContents
Set destino = Range("a500").Resize(origen.Rows.Count, origen.Columns.Count)
ReDim matriz(datos.Rows.Count, datos.Columns.Count)

a = 1
For Each Fila In origen.Rows
    fil = Fila.Row - origen.Row + 1
    f = Fila
    If f(1, 4) = Empty Then GoTo siguiente
    
    For i = 1 To origen.Columns.Count
        matriz(a, i) = f(1, i)
    Next i
    a = a + 1
siguiente:
Next Fila

Range(destino.Address) = matriz
origen.Rows(0).Copy destino.Rows(0)
'destino.Select
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

SEGUNDA MAGRO - BOTON COPIAR REGISTROS DE UNA HOJA A LA BASE DE DATOS EXTERNA

Sub copia2()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
Set hd = Workbooks("0. Base_Datos_Acumulada.xlsm")
Set destino = hd.ActiveSheet.Range("a1").CurrentRegion

Set ho = ActiveWorkbook
Set origen = ho.ActiveSheet.Range("a500").CurrentRegion

c = origen.Rows(1).Interior.ColorIndex

If c = 15 Then
    Set origen = origen.Rows(2).Resize(origen.Rows.Count - 1, origen.Columns.Count)
End If

origen.Copy destino.Rows(destino.Rows.Count + 1)
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

No tengo palabras para agradecerle todo lo que me ha aguantado, he aprendido, pero cada vez veo que se menos.

 

Muchas gracias y mil gracias.

 

0. Base_Datos_Acumulada - copia.xlsm

 

Dr. Hyde, buenas tardes, como hago para borrar estos ultimos mensajes que están repetidos?

Gracias

con un boton basta para correr las dos macros solo haz esto por cada boton que tengas por hoja

Private Sub CommandButton2_Click()
copiar

copia2
End Sub

abajo de tus mensajes hay 3 botones seleccion opciones, borrar y listo

Dr. Hyde como hago para continuar, sinceramente faltan detallitos, porque ya me funciona bien, pero hay algo que quiero preguntarle.

Entonces cierro el tema?

cual es la duda?

Buenas tardes, es la siguiente:

1. Cuando copio las filas no me quedan con el formato que viene la base de datos

2. Tengo dos botenes, asi como me lo explicaste, 

• El primero "Copiar" y copia las filas sin ninguna en blaco
• El segundo "Copia2" que pasa los registros a la Base de Datos Externa.

La pregunta es, se puede hacer en uno solo?

Gracias nuevamente, en verdad sos un verdadero genio, lo felicito.

para el formato y ya no moverle a las macros copia esta macro donde tienes las dos macros para copiar, esta le daran formato en el libro de acumulados

Sub formato()
Set hd = Workbooks("0. Base_Datos_Acumulada - copia.xlsm")
Set destino = hd.Sheets(1).Range("a1").CurrentRegion
    
    destino.Borders(xlDiagonalDown).LineStyle = xlNone
    destino.Borders(xlDiagonalUp).LineStyle = xlNone
    With destino.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With destino.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With destino.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With destino.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With destino.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With destino.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
 

la segunda en el boton copiar, añade el siguiente codigo y tendras en un solo boton las tres macros

Private Sub CommandButton2_Click()
copiar

copia2

formato
End Sub

Gracias Dr. Hyde, procederé a realizar esto para cerrar el tema, que pena con usted, molestarlo tanto, pero he aprendido mucho, aunque me falta cantidades.

Nuevamente Gracias y mil Gracias.

Le comentare como me fue.

 

Dr. Hyde, buenos días

Realice lo que me escribió y funciono perfecto, pero hay un detalle, los campos o celdas que tienen numeros enteros, separados de dos decimales, no quedan con el formato, es decir:

77,999 queda 77999

Las columnas son de la "J" a la "AD"

En cambio de de la "AJ" a la "AM" si quedan con el formato de miles.

Porque? no se, analice la Macro y no veo el motivo.

Te relaciono la Macro por si ves donde esta el porque copia unas columnas con formato de miles y las otras no:

Option Base 1
Sub copiar()
' Desabilita los campos de Nombre Px y Tratamiento
    Application.EnableEvents = False
    Application.ScreenUpdating = False
' Desprotege la hoja
Cells.Select
    Range("C1").Activate
    ActiveSheet.Unprotect
' Empieza el traslado de los registros sin filas en blanco
Set datos = Range("a320").CurrentRegion
Set datos = datos.Rows(1).Resize(149, datos.Columns.Count)

Set origen = datos.Offset(1, 0).Resize(datos.Rows.Count - 1, datos.Columns.Count)
Range("a500").Resize(origen.Rows.Count, origen.Columns.Count).ClearContents
Set destino = Range("a500").Resize(origen.Rows.Count, origen.Columns.Count)
ReDim matriz(datos.Rows.Count, datos.Columns.Count)

a = 1
For Each Fila In origen.Rows
    fil = Fila.Row - origen.Row + 1
    f = Fila
    If f(1, 4) = Empty Then GoTo siguiente
    
    For i = 1 To origen.Columns.Count
        matriz(a, i) = f(1, i)
    Next i
    a = a + 1
siguiente:
Next Fila

Range(destino.Address) = matriz
origen.Rows(0).Copy destino.Rows(0)
'destino.Select
' Protege la hoja
 Cells.Select
    Range("C1").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Habilita campos de Nombre Px y Tratamientos
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 

De resto funciono perfectamente, estoy muy contento, pero si no se puede Dr, tranquilo, no sabes como me ayudo, y cada vez lo pulo màs, pero con la ayuda de ustedes, porque solo era imposible hacerlo.

Gracias

en la macro formato antes del end sub coloca estas instrucciones

Set destino = destino.Offset(1, 9).Resize(destino.Rows.Count - 1, 21)
destino.NumberFormat = "#,##0"

deja los numeros tal como quieres

Dr. Hyde, buenas tardes

Quedo EXCELENTE, funciona a la perfección.

Todos los formatos quedaron "Ok"

La copia de los registros en la Base de Datos Externa los copia muy bien.

Gracias, muchisimas gracias.

Verdaderamente el que sabe, sabe, lo Felicito.

 

PODEMOS DAR POR TERMINADO ESTE TEMA

Disculpeme si lo moleste demasiado, pero sin usted nunca lo habría realizado.

Gracias

Dr Hyde, no crea que le escribo solo para que me ayude, también para FELICITARLO y agradecerle que me ha soportado tanto.

Como escribí anteriormente podemos dar por Cerrado este Tema.

Voy a continuar mejorando la hoja, ahora quiero que cuando se posicione en el nombre tome una Base de datos de Nombre, lo voy a intentar hacer.

 

Gracias nuevamente

solo escribe tema solucionado para que un administrador cierre el tema 

Dr. Hyde, buenas tardes

TEMA SOLUCIONADO

Gracias

Buenos días,

ESTE TEMA FUE TERMINADO CON ÉXITO.

 

Gracias