VBA- EXCEL - No puedo pegar mis datos en otra hoja
publicado
Mi codigo esta funcionando al 90% ya que cuando estoy por finalizarlo, y deseo pegar datos que copie previamente de otra hoja, el codigo se interrumpe y no encuentro manera de dejarlo funcional.
Estoy copiando datos de la hoja "Tabla1" y los estoy pegando en un libro llamado "REPORTE CC_MACRO" en la hoja "tabla base".
El codigo se interrumpe en
' 3. Una vez seleccionada la celda D3, pegar los datos que se copiaron en pasos anteriores
Selection.PasteSpecial Paste:=xlPasteValues
Codigo completo:
Sub BASEV1OK()
Dim wsOrigen As Worksheet
Dim wsOrigen2 As Worksheet
Dim wsDestino As Worksheet
Dim rngOrigen As Range
Dim rngDestino As Range
Dim rngOrigen2 As Range
Dim ultFila As Long
' Definir la hoja de trabajo Original - Dim wsOrigen As Worksheet
Set wsOrigen = ThisWorkbook.Sheets("original")
' Obtener la última fila en la columna S - Dim ultFila As Long
ultFila = wsOrigen.Cells(wsOrigen.Rows.Count, "S").End(xlUp).Row
' ----------------------------
'' RANGO PARA ORDENAR COLUMNAS A O P - Definir el rango de datos de origen excluyendo la primera fila y limitando hasta la columna S
'Set rngOrigen = wsOrigen.Range("A2", wsOrigen.Cells(wsOrigen.Rows.Count, "S").End(xlUp))
' RANGO PARA ORDENAR COLUMNAS A O P - Definir el rango de datos de origen excluyendo la primera fila y limitando hasta la columna S
Set rngOrigen = wsOrigen.Range("A2:S" & ultFila)
' Ordenar por las columnas A, O y P de menor a mayor
MsgBox "Ordenando datos por las columnas A, O y P..."
With rngOrigen
.Sort Key1:=.Columns("A"), Order1:=xlAscending, _
Key2:=.Columns("O"), Order2:=xlAscending, _
Key3:=.Columns("P"), Order3:=xlAscending, _
Header:=xlYes
End With
MsgBox "Ordenación completada."
' ----------------------------
'RANGO PARA FILTRAR COLUMNAS Definir el rango de datos de origen excluyendo la primera fila
Set rngOrigen2 = wsOrigen.Range("A1", wsOrigen.Cells(wsOrigen.Rows.Count, "A").End(xlUp).Offset(, wsOrigen.Cells(1, wsOrigen.Columns.Count).End(xlToLeft).Column))
' Aplicar filtro en la columna R
MsgBox "Aplicando filtro en la columna R..."
With rngOrigen2
' Limpiar filtros existentes
.AutoFilter
' Aplicar filtro personalizado en la columna R
rngOrigen2.AutoFilter Field:=18, Criteria1:=Array("** Sin Uso **", "Clientes en mora", "En Juicio", "Sin Operar"), Operator:=xlFilterValues
End With
MsgBox "Filtro aplicado."
' ----------------------------
' Seleccionar las celdas visibles después de aplicar el filtro
On Error Resume Next ' Ignorar error si no hay celdas visibles
Dim rngFiltrado As Range
Set rngFiltrado = rngOrigen.SpecialCells(xlCellTypeVisible) ' SE TOMA EL RANGO SIN LOS TITULARES PARA QUE NO LO ELIMINE
On Error GoTo 0 ' Restaurar manejo normal de errores
' Verificar si se encontraron celdas visibles
If Not rngFiltrado Is Nothing Then
' Eliminar las filas filtradas
rngFiltrado.EntireRow.Delete
Else
MsgBox "No se encontraron datos filtrados para eliminar.", vbInformation
End If
' Limpiar filtro
wsOrigen.AutoFilterMode = False
' ----------------------------
' ' Seleccionar todo el contenido activo de la hoja
' rngOrigen.Copy
' Copiar solo las celdas desde A hasta S en lugar de todas las columnas
wsOrigen.Range("A2:N" & ultFila).Copy
MsgBox "Tabla copiada"
' Crear una nueva hoja llamada "Tabla1"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Tabla1"
' ----------------------------
' Definir la hoja de trabajo Tabla1
Set wsOrigen2 = ThisWorkbook.Sheets("Tabla1")
' ----------------------------
' Definir la hoja de destino
Set wsDestino = ThisWorkbook.Sheets("Tabla1")
' ' Pegar los datos en la hoja de destino (solo las columnas A a S)
'wsDestino.Range("A1:N" & rngOrigen.Rows.Count).PasteSpecial Paste:=xlPasteValues
' Pegar los datos en la hoja de destino (solo las columnas A a S)
wsDestino.Range("A1").PasteSpecial Paste:=xlPasteValues
' Limpiar el portapapeles
Application.CutCopyMode = False
' ' Eliminar la fila de títulos en la hoja de destino - NO SE USA YA QUE ESTOY PEGANDO TABLA SIN TITULOS
' wsDestino.Rows(1).Delete
' Limpiar filtros en la hoja de origen
wsOrigen.AutoFilterMode = False
' ----------------------------
' ------Verificar si el archivo "REPORTE CC_MACRO" está abierto
If WorkbookIsOpen("REPORTE CC _MACRO.xlsm") Then
Dim wsReporte As Worksheet
Set wsReporte = Workbooks("REPORTE CC _MACRO.xlsm").Sheets("Tabla Base")
' 2. Si está abierto, activar la hoja "Tabla Base" y seleccionar la celda D3
With wsReporte
.Activate
.Range("D3").Select
End With
' 3. Una vez seleccionada la celda D3, pegar los datos que se copiaron en pasos anteriores
Selection.PasteSpecial Paste:=xlPasteValues
' 4. Desactivar modo de copia
Application.CutCopyMode = False
' ' --------Pegar los datos desde el array al rango de destino
' rngDestino.Resize(UBound(rngOrigen.Value, 1), UBound(rngOrigen.Value, 2)).Value = rngOrigen.Value
' 5. Mostrar mensaje de éxito
MsgBox "Datos pegados exitosamente."
' 6. Mostrar mensaje si el archivo "REPORTE CC_MACRO" está cerrado
Else
MsgBox "El archivo 'REPORTE CC _MACRO.xlsm' no está abierto.", vbExclamation
End If
End Sub
Function WorkbookIsOpen(workbookName As String) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(workbookName)
WorkbookIsOpen = Not wb Is Nothing
On Error GoTo 0
End Function
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
Mi codigo esta funcionando al 90% ya que cuando estoy por finalizarlo, y deseo pegar datos que copie previamente de otra hoja, el codigo se interrumpe y no encuentro manera de dejarlo funcional.
Estoy copiando datos de la hoja "Tabla1" y los estoy pegando en un libro llamado "REPORTE CC_MACRO" en la hoja "tabla base".
El codigo se interrumpe en
Codigo completo:
Sub BASEV1OK() Dim wsOrigen As Worksheet Dim wsOrigen2 As Worksheet Dim wsDestino As Worksheet Dim rngOrigen As Range Dim rngDestino As Range Dim rngOrigen2 As Range Dim ultFila As Long ' Definir la hoja de trabajo Original - Dim wsOrigen As Worksheet Set wsOrigen = ThisWorkbook.Sheets("original") ' Obtener la última fila en la columna S - Dim ultFila As Long ultFila = wsOrigen.Cells(wsOrigen.Rows.Count, "S").End(xlUp).Row ' ---------------------------- '' RANGO PARA ORDENAR COLUMNAS A O P - Definir el rango de datos de origen excluyendo la primera fila y limitando hasta la columna S 'Set rngOrigen = wsOrigen.Range("A2", wsOrigen.Cells(wsOrigen.Rows.Count, "S").End(xlUp)) ' RANGO PARA ORDENAR COLUMNAS A O P - Definir el rango de datos de origen excluyendo la primera fila y limitando hasta la columna S Set rngOrigen = wsOrigen.Range("A2:S" & ultFila) ' Ordenar por las columnas A, O y P de menor a mayor MsgBox "Ordenando datos por las columnas A, O y P..." With rngOrigen .Sort Key1:=.Columns("A"), Order1:=xlAscending, _ Key2:=.Columns("O"), Order2:=xlAscending, _ Key3:=.Columns("P"), Order3:=xlAscending, _ Header:=xlYes End With MsgBox "Ordenación completada." ' ---------------------------- 'RANGO PARA FILTRAR COLUMNAS Definir el rango de datos de origen excluyendo la primera fila Set rngOrigen2 = wsOrigen.Range("A1", wsOrigen.Cells(wsOrigen.Rows.Count, "A").End(xlUp).Offset(, wsOrigen.Cells(1, wsOrigen.Columns.Count).End(xlToLeft).Column)) ' Aplicar filtro en la columna R MsgBox "Aplicando filtro en la columna R..." With rngOrigen2 ' Limpiar filtros existentes .AutoFilter ' Aplicar filtro personalizado en la columna R rngOrigen2.AutoFilter Field:=18, Criteria1:=Array("** Sin Uso **", "Clientes en mora", "En Juicio", "Sin Operar"), Operator:=xlFilterValues End With MsgBox "Filtro aplicado." ' ---------------------------- ' Seleccionar las celdas visibles después de aplicar el filtro On Error Resume Next ' Ignorar error si no hay celdas visibles Dim rngFiltrado As Range Set rngFiltrado = rngOrigen.SpecialCells(xlCellTypeVisible) ' SE TOMA EL RANGO SIN LOS TITULARES PARA QUE NO LO ELIMINE On Error GoTo 0 ' Restaurar manejo normal de errores ' Verificar si se encontraron celdas visibles If Not rngFiltrado Is Nothing Then ' Eliminar las filas filtradas rngFiltrado.EntireRow.Delete Else MsgBox "No se encontraron datos filtrados para eliminar.", vbInformation End If ' Limpiar filtro wsOrigen.AutoFilterMode = False ' ---------------------------- ' ' Seleccionar todo el contenido activo de la hoja ' rngOrigen.Copy ' Copiar solo las celdas desde A hasta S en lugar de todas las columnas wsOrigen.Range("A2:N" & ultFila).Copy MsgBox "Tabla copiada" ' Crear una nueva hoja llamada "Tabla1" Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Tabla1" ' ---------------------------- ' Definir la hoja de trabajo Tabla1 Set wsOrigen2 = ThisWorkbook.Sheets("Tabla1") ' ---------------------------- ' Definir la hoja de destino Set wsDestino = ThisWorkbook.Sheets("Tabla1") ' ' Pegar los datos en la hoja de destino (solo las columnas A a S) 'wsDestino.Range("A1:N" & rngOrigen.Rows.Count).PasteSpecial Paste:=xlPasteValues ' Pegar los datos en la hoja de destino (solo las columnas A a S) wsDestino.Range("A1").PasteSpecial Paste:=xlPasteValues ' Limpiar el portapapeles Application.CutCopyMode = False ' ' Eliminar la fila de títulos en la hoja de destino - NO SE USA YA QUE ESTOY PEGANDO TABLA SIN TITULOS ' wsDestino.Rows(1).Delete ' Limpiar filtros en la hoja de origen wsOrigen.AutoFilterMode = False ' ---------------------------- ' ------Verificar si el archivo "REPORTE CC_MACRO" está abierto If WorkbookIsOpen("REPORTE CC _MACRO.xlsm") Then Dim wsReporte As Worksheet Set wsReporte = Workbooks("REPORTE CC _MACRO.xlsm").Sheets("Tabla Base") ' 2. Si está abierto, activar la hoja "Tabla Base" y seleccionar la celda D3 With wsReporte .Activate .Range("D3").Select End With ' 3. Una vez seleccionada la celda D3, pegar los datos que se copiaron en pasos anteriores Selection.PasteSpecial Paste:=xlPasteValues ' 4. Desactivar modo de copia Application.CutCopyMode = False ' ' --------Pegar los datos desde el array al rango de destino ' rngDestino.Resize(UBound(rngOrigen.Value, 1), UBound(rngOrigen.Value, 2)).Value = rngOrigen.Value ' 5. Mostrar mensaje de éxito MsgBox "Datos pegados exitosamente." ' 6. Mostrar mensaje si el archivo "REPORTE CC_MACRO" está cerrado Else MsgBox "El archivo 'REPORTE CC _MACRO.xlsm' no está abierto.", vbExclamation End If End Sub Function WorkbookIsOpen(workbookName As String) As Boolean Dim wb As Workbook On Error Resume Next Set wb = Workbooks(workbookName) WorkbookIsOpen = Not wb Is Nothing On Error GoTo 0 End Function