Copiar contenido a diferentes hojas según cumpla con criterio de una celda

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
  3. Web
Buenas tardes, les escribo para que me brinden su ayuda con una macro, les estaré muy agradecida, les paso a contar:

Tengo una macro con varias hojas, en la hoja "carga de datos" hay un formulario de carga, en la celda C15 una lista desplegable con varias opciones, lo que quiero es si se cumple una de las opciones me copia los datos cargados en el formulario en la hoja que lleva el mismo nombre:

Las opciones de la celda C15 son las siguientes:

Censos
Monografías
Revistas
Serie

Ahora copia todo en la carpeta "datos" pero sería más eficiente si lo copia en la hoja que corresponde.

Mi macro
Opción explícita
Sub Captura_Datos ()
'Comando para que no parpadee
Application.ScreenUpdating = False

«Comando para desproteger hoja
ActiveSheet.Unprotect Password: = "1234"

«Declaración de variables
'
Dim strTitulo As String
Dim Continuar como cadena
Dim TransRowRng As Range
Dim NewRow As Integer
Dim Limpiar como cadena
'
strTitulo = "Inventario Digital"
'
Continuar = MsgBox ("Dar de alta los datos?", VbSí No + vbExclamation, strTitulo)
Si Continuar = vbNo, entonces salga de Sub
'
Establecer TransRowRng = ThisWorkbook.Worksheets ("Datos"). Celdas (1, 1) .Región actual
NewRow = TransRowRng.Rows.Count + 1
Con ThisWorkbook.Worksheets ("Datos")
.Cells (NewRow, 1) .Value = Date
.Cells (NewRow, 2) .Value = ThisWorkbook.Sheets (1) .Range ("C9") 'Base de datos
.Cells (NewRow, 3) .Value = ThisWorkbook.Sheets (1) .Range ("C11") 'Tipo de recurso
.Cells (NewRow, 4) .Value = ThisWorkbook.Sheets (1) .Range ("C13") 'Nombre de archivo
.Cells (NewRow, 5) .Value = ThisWorkbook.Sheets (1) .Range ("C15") 'Carpeta
.Cells (NewRow, 6) .Value = ThisWorkbook.Sheets (1) .Range ("C17") 'Subido a la Web

Terminar con
MsgBox "Alta exitosa", vbInformation, strTitulo
Limpiar = MsgBox ("¿Deseas limpiar los campos de la captura?", Vb Sí, strTitulo)
Si Limpiar = vb Sí, entonces
Con ActiveWorkbook.Sheets (1)
.Range ("C9"). ClearContents
.Range ("C11"). ClearContents
.Range ("C13"). ClearContents
.Range ("C15"). ClearContents
.Range ("C17"). ClearContents
'ClearContents no funciona en celda combinada ...
Terminar con
Más
Terminara si
ActiveSheet.Protect Contraseña: = "1234"
End Sub



Muchas gracias de antemano

Saludos

Silvina
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,852
Office Version
  1. 2007
Platform
  1. Windows
Hola y bienvenida a MrExcel!
Supongo que algunas palabras del código fueron traducidas por el traductor automático.

Si la hoja destino es la que tiene password, entonces utiliza esta macro:

VBA Code:
Sub Captura_Datos()
'DECLARACIÓN de variables
  Dim strTitulo As String, hoja As String
  Dim sh As Worksheet, lr As Long
'DATOS iniciales
  strTitulo = "Inventario Digital"
  Set sh = Sheets(1)
  hoja = sh.Range("C15").Value
  If hoja = "" Then
    MsgBox "Captura la hoja", vbCritical, strTitulo
    Exit Sub
  End If
  If Evaluate("ISREF('" & hoja & "'!A1)") = False Then
    MsgBox "No existe la hoja : " & hoja, vbCritical, strTitulo
    Exit Sub
  End If
  If MsgBox("Dar de alta los datos?", vbYesNo + vbQuestion, strTitulo) = vbNo Then Exit Sub
'PROCESO
  With Sheets(hoja)
    .Unprotect Password:="1234"
    lr = .Range("A" & Rows.Count).End(3).Row + 1
    .Range("A" & lr).Value = Date
    .Range("B" & lr).Value = sh.Range("C9")     'Base de datos
    .Range("C" & lr).Value = sh.Range("C11")    'Tipo de recurso
    .Range("D" & lr).Value = sh.Range("C13")    'Nombre de archivo
    .Range("E" & lr).Value = sh.Range("C15")    'Carpeta
    .Range("F" & lr).Value = sh.Range("C17")    'Subido a la Web
    .Protect Password:="1234"
  End With
'
  If MsgBox("Alta exitosa" & vbCr & "¿Deseas limpiar los campos de la captura?", vbYesNo + vbQuestion, strTitulo) = vbYes Then
    sh.Range("C9, C11, C13, C15, C17").ClearContents
  End If
End Sub

Si la hoja(1) es la que tiene el password, me parece que no es necesario poner y quitar el password, porque solamente estás utilizando las celdas que supongo están desbloqueadas.

De cualquier forma, prueba y me comentas.
 

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
  3. Web
Funciono perfectamente, te agradezco mucho el tiempo.
Saludos
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,852
Office Version
  1. 2007
Platform
  1. Windows
Un placer ayudarte. Gracias por comentar.
 

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
  3. Web

ADVERTISEMENT

Consulta: este código que me pasaste
lr = .Range("A" & Rows.Count).End(3).Row + 1
me copia en la ultima fila vacia, me gustaría que lo copie en la fila 7, lo mas reciente arriba. Y si es posible podrías indicarme en donde introduzco el código para que la columna A aparezca el numero siguiente "ID". Cada tabla tiene en la columna A un número que se autoincrementa.

Mucha gracias
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,852
Office Version
  1. 2007
Platform
  1. Windows
Y si es posible podrías indicarme en donde introduzco el código para que la columna A aparezca el numero siguiente "ID". Cada tabla tiene en la columna A un número que se autoincrementa.

Ya no quieres la fecha en la columna A?

Si "autoincrementa", entonces si pones lo más reciente en la celda A7, qué número va en la celda A7, el número 1?
 

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
  3. Web
Hola, en la columna A iría el ID, le paso una imagen de la tabla para que sea mas claro.
Muchas gracias y disculpa la desprolijidad de mis preguntas, en la medida que avanzo en el proyecto se me van ocurriendo algunas modificaciones. Esto es una de las hojas a donde copia la información del formulario, todas las hojas tienen el mismo formato.
1591577688088.png
 

Watch MrExcel Video

Forum statistics

Threads
1,133,426
Messages
5,658,729
Members
418,467
Latest member
sc356448

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top