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

[silvinads]

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

 

[DanteAmor]

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:

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]

Funciono perfectamente, te agradezco mucho el tiempo.
Saludos

 

[DanteAmor]

Un placer ayudarte. Gracias por comentar.

 

[silvinads]

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]

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]

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.