¿Como puedo hacer que la macro solo pegue valores?

Para "Dante Amor"

Saludos mi amigo, ante todo gracias por compartir tus conocimientos y ayuda a la comunidad en general.

Tengo el siguiente problema, como puedo hacer que la macro de copiar archivos a un otro solo pegue valores.

Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja1")
On Error Resume Next
Do While archi <> ""
    If InStr(1, archi, "nuevo") = 0 Then
        Workbooks.Open archi
        If Err.Number = 0 Then
            Sheets(1).Select
            uf1 = h1.Range("A" & Rows.Count).End(xlUp).Row
            Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy _
            h1.Range("B" & uf1 + 1)
            uf2 = uf1 + ActiveCell.SpecialCells(xlLastCell).Row
            Application.DisplayAlerts = False
            Workbooks(archi).Close
            Application.DisplayAlerts = True
            If uf1 > 1 Then uf1 = uf1 + 1
            Range("A" & uf1 & ":A" & uf2) = archi
        Else
            Err.Number = 0
        End If
    End If
    archi = Dir()
Loop
End Sub

1 respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada

Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
    Application.ScreenUpdating = False
    ruta = ThisWorkbook.Path
    ChDir ruta
    archi = Dir("*.xls*")
    Set h1 = ThisWorkbook.Sheets("hoja1")
    On Error Resume Next
    Do While archi <> ""
        If InStr(1, archi, "nuevo") = 0 Then
            Workbooks.Open archi
            If Err.Number = 0 Then
                Sheets(1).Select
                uf1 = h1.Range("A" & Rows.Count).End(xlUp).Row
                Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy
                h1.Range("B" & uf1 + 1).PasteSpecial xlValues
                uf2 = uf1 + ActiveCell.SpecialCells(xlLastCell).Row
                Application.DisplayAlerts = False
                Workbooks(archi).Close
                Application.DisplayAlerts = True
                If uf1 > 1 Then uf1 = uf1 + 1
                Range("A" & uf1 & ":A" & uf2) = archi
            Else
                Err.Number = 0
            End If
        End If
        archi = Dir()
    Loop
    MsgBox "Libros copiados", vbInformation, "FIN"
End Sub

Avísame cualquier detalle.


':)
'S aludos. D a n t e   A m o r . R ecuerda valorar la respuesta. G racias
':)

Mil gracias funciona perfecto mi amigo Dante Amor.

Pero si me aclaras porque en la versión original de la primera macro, para aplicar el mismo caso de pegado especial no me funciono.

Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja1")
On Error Resume Next
Do While archi <> ""
If InStr(1, archi, "nuevo") = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(1).Select
Range(Range("A20"), ActiveCell.SpecialCells(xlLastCell)).Copy
h1.Range("A" & h1.Range("A1")).PasteSpecial xlValues
ActiveCell.SpecialCells(xlLastCell).Row
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub

En la macro original no copiaba valores, copia toda la celda con formatos:

Range(Range("A1"), ActiveCell. SpecialCells(xlLastCell)).Copy _
            H1.Range("B" & uf1 + 1)

El cambio en la macro:

Range(Range("A1"), ActiveCell. SpecialCells(xlLastCell)). Copy
                H1.Range("B" & uf1 + 1). PasteSpecial xlValues

sal u dos

¡Gracias! 

Eres un Genio 

Me quedo la duda,  cuando dije la macro original fue, la primera que observe de una consulta de otro usuario, el cual no insertaba el nombre del archivo de la hoja copiada.

Espero tu ayuda y comprensión ya que hice el intento siguiendo tu guía anterior y no me funciona.

Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja1")
On Error Resume Next
Do While archi <> ""
If InStr(1, archi, "nuevo") = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(1).Select
Range(Range("A20"), ActiveCell.SpecialCells(xlLastCell)).Copy _
h1.Range("A" & h1.Range("A1").SpecialCells(xlLastCell).Row + 1)
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub

¿Cuál duda tienes?

La duda es que en la macro del comentario anterior no tiene las variables o instrucciones uf1 y uf2   que son las que de un modo le genera al nuevo libro el nombre del archivo de origen.

Entonces como se hace para indicarle que solo haga pegado especial 

La macro utiliza las variables uf1 y uf2 para rellenar la columna A con el nombre del archivo.

¿Ya no quieres que ponga el nombre del libro en la columna A?

Sigo sin entender, ¿tienes una duda? ¿O quieres cambios en la macro?

si señor esa es la otra opción que no coloque el nombre del archivo en la columna A

Te anexo la macro para que no ponga el nombre del archivo en la columna A

Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
    Application.ScreenUpdating = False
    ruta = ThisWorkbook.Path
    ChDir ruta
    archi = Dir("*.xls*")
    Set h1 = ThisWorkbook.Sheets("hoja1")
    On Error Resume Next
    Do While archi <> ""
        If InStr(1, archi, "nuevo") = 0 Then
            Workbooks.Open archi
            If Err.Number = 0 Then
                Sheets(1).Select
                uf1 = h1.Range("A" & Rows.Count).End(xlUp).Row
                Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Copy
                h1.Range("A" & uf1 + 1).PasteSpecial xlValues
                'uf2 = uf1 + ActiveCell.SpecialCells(xlLastCell).Row
                Application.DisplayAlerts = False
                Workbooks(archi).Close
                Application.DisplayAlerts = True
                'If uf1 > 1 Then uf1 = uf1 + 1
                'Range("A" & uf1 & ":A" & uf2) = archi
            Else
                Err.Number = 0
            End If
        End If
        archi = Dir()
    Loop
    MsgBox "Libros copiados", vbInformation, "FIN"
End Sub

sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas