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

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
2019
Platform
Windows, Mobile, 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
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,809
Office Version
2007
Platform
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
2019
Platform
Windows, Mobile, Web
Funciono perfectamente, te agradezco mucho el tiempo.
Saludos
 

DanteAmor

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

silvinads

New Member
Joined
Jun 5, 2020
Messages
4
Office Version
2019
Platform
Windows, Mobile, Web
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
11,809
Office Version
2007
Platform
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
2019
Platform
Windows, Mobile, 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,099,626
Messages
5,469,785
Members
406,670
Latest member
Jimborusk13

This Week's Hot Topics

Top