Macro para adicionar registros de una hoja a una base de datos nueva

[Dr Hyde]

copiar el boton no significa que la macro se copia, cada que copies el boton debes entrar al boton y darle el nombre la macro que se va a ejecutar en este caso copia2, das click con el boton derecho sobre el boton y seleccionas ver codigo, si esta vacia te va a aparecer asi:

el numero se va a ir incrementado cada que hagas una copia

Private Sub CommandButton2_Click()
End Sub

tu agregas lo siguiente

Private Sub CommandButton2_Click()
copia2
End Sub

y la macro tiene que estar en el libro que estes usando sino te va a marcar error

[Oscar Arroyave]

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

 

[Oscar Arroyave]

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

[Oscar Arroyave]

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

[Oscar Arroyave]

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

[Oscar Arroyave]

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

 

[Oscar Arroyave]

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

Gracias

[Dr Hyde]

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

[Oscar Arroyave]

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

Entonces cierro el tema?

[Dr Hyde]

cual es la duda?

[Oscar Arroyave]

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.

[Dr Hyde]

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
 

[Dr Hyde]

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

[Oscar Arroyave]

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.

 

[Oscar Arroyave]

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

[Dr Hyde]

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

[Oscar Arroyave]

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

[Oscar Arroyave]

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

[Dr Hyde]

solo escribe tema solucionado para que un administrador cierre el tema 

[Oscar Arroyave]

Dr. Hyde, buenas tardes

TEMA SOLUCIONADO

Gracias

[Oscar Arroyave]

Buenos días,

ESTE TEMA FUE TERMINADO CON ÉXITO.

 

Gracias