Modificar macro para que también copie las fórmulas de las celdas
Quisiera que la macro que adjuntare también copie las fórmulas, ya no solo los valores de las celdas, he intentando agregando según lo que investigue en internet: "ws2.Range(celda.Address).Fórmula = celda.Fórmula", pero me da error 1004
[quote]
Sub TransferirDatos()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim celda As Range
Dim origen As String
Dim destino As String
Dim archivos() As String
Dim archivo As Variant
Dim hojas As Range
Dim i As Long
'Selecciona la carpeta origen
origen = BrowseForFolder("Selecciona la carpeta origen.")
'Sale de la macro si se cancela la selección de carpeta origen
If origen = "" Then Exit Sub
'Selecciona la carpeta destino
destino = BrowseForFolder("Selecciona la carpeta destino.")
'Sale de la macro si se cancela la selección de carpeta destino
If destino = "" Then Exit Sub
'Guarda las rutas completas en los rangos correspondientes
ThisWorkbook.Sheets("transf").Range("I4").Value = origen
ThisWorkbook.Sheets("transf").Range("I5").Value = destino
'Verifica si la carpeta origen y destino son la misma
If origen = destino Then
MsgBox "La carpeta origen y destino son la misma. Seleccione una carpeta de destino diferente.", vbCritical
Exit Sub
End If
Call AgregarDos
'Obtiene la lista de archivos en la carpeta origen
archivos = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & origen & "*.xls*"" /A:-D /B").StdOut.ReadAll, vbCrLf)
'Abre el primer archivo en la carpeta origen
Set wb1 = Workbooks.Open(origen & archivos(0))
'Ejecuta la macro ListaHojas para escribir los nombres de las hojas en la hoja "transf"
ListaHojas wb1
'Recorre la lista de archivos en la carpeta origen
For Each archivo In archivos
'Abre el archivo en la carpeta origen
On Error GoTo fin
Set wb1 = Workbooks.Open(origen & archivo)
'Abre el archivo en la carpeta destino y desbloquea todas sus hojas
Set wb2 = Workbooks.Open(destino & Replace(archivo, ".xls", "2.xls"), , , , "Dr4gOnnike01(_0)x-+dass@LOL@#=)$#LFMAO")
For Each ws2 In wb2.Worksheets
ws2.Unprotect "Dr4gOnnike01(_0)x-+dass@LOL@#=)$#LFMAO"
Next ws2
'Recorre la lista de hojas en la hoja "transf"
For i = 2 To 39
'Verifica si hay un "SI" en la columna A
If ThisWorkbook.Sheets("transf").Range("A" & i).Value = "SI" Then
'Obtiene el nombre de la hoja
Dim hoja As String
hoja = ThisWorkbook.Sheets("transf").Range("B" & i).Value
'Verifica si la hoja existe en el libro 2
On Error Resume Next
Set ws2 = wb2.Sheets(hoja)
On Error GoTo 0
If ws2 Is Nothing Then
MsgBox "La hoja " & hoja & " no existe en el libro de destino.", vbCritical
Exit Sub
End If
'Transfiere los valores de las celdas
Set ws1 = wb1.Sheets(hoja)
For Each celda In ws1.UsedRange
If Not IsEmpty(celda.Value) Then
ws2.Range(celda.Address).Value = celda.Value
End If
Next celda
End If
Next i
'Guarda y cierra los libros
wb2.Close True
wb1.Close False
Next archivo
'Finaliza la macro
MsgBox "Los datos han sido transferidos exitosamente.", vbInformation
fin: MsgBox "Los datos han sido transferidos exitosamente.", vbInformation
Call QuitarDos
End Sub