Copiar celdas en diferentes hojas de un libro.
Hola Dante,
Hace poco me ayudaste con un código para poder copiar de un libro a otro y que se copie en diferentes hojas según los datos en la celda "D5".
Por favor necesito que en este código me ayudes con unos procesos más que debe cumplir:
- Cuando la macro crea una nueva hoja la crea con el nombre que esta en la celda "D5", esta celda en el libro que va a ser copiado tiene muchos ceros adelante Ejemplo: "00000000876", por lo tanto la nueva hoja tiene el nombre: "00000000876". Intente sumarle un cero y con eso se quita los ceros, pero al ponerlo en la macro no me funciona bien al copiar una hoja que ya existe, me sale un error 1004. Cómo podría nombrar la hoja sin los "0"
- Siempre que copie los datos de un libro a otro cuando sea una hoja nueva lo comience hacer desde la columna F.
- Cuando copie los datos a una hoja que ya existe lo haga en la columna siguiente, es decir, si ya hay datos en la columna F, que lo haga en la G, y así sucesivamente.
- Por ultimo que todas las columnas a partir de la F tengan un ancho de 40
De antemano muchas gracias por tu valiosa ayuda.
Sub Copiar_informacion_adjuntos()
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
ruta = "C:\Users\z003bpca\Desktop\Bitacora\"
arch = "copy_Reporte.xls"
If Dir(ruta & arch) = "" Then
MsgBox "El archivo Reporte no existe en la ruta", vbCritical
Exit Sub
End If
'
Set l2 = Workbooks.Open(ruta & arch)
Set h2 = l2.Sheets("Sheet0")
Num = h2.Range("D5").Text
If Num = "" Then
MsgBox "La celda D5 no contiene datos", vbExclamation
l2.Close False
Exit Sub
End If
'
existe = False
For Each h In l1.Sheets
If h.Name = Num Then
existe = True
Set h1 = h
Exit For
End If
Next
'
If existe = False Then
l1.Sheets.Add after:=l1.Sheets(l1.Sheets.Count)
Set h1 = ActiveSheet
h1.Name = Num
End If
'
h2.Range("O42:O99").Copy h1.Range("A1")
l2.Close False
l1.Save
MsgBox "Copia realizada", vbInformation
End Sub
1 respuesta
Respuesta de Dante Amor
1
Te anexo la macro para las 3 primeras peticiones.
Sub Copiar_informacion_adjuntos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
ruta = "C:\Users\z003bpca\Desktop\Bitacora\"
'ruta = "C:\trabajo\"
arch = "copy_Reporte.xls"
If Dir(ruta & arch) = "" Then
MsgBox "El archivo Reporte no existe en la ruta", vbCritical
Exit Sub
End If
'
Set l2 = Workbooks.Open(ruta & arch)
Set h2 = l2.Sheets("Sheet0")
num = h2.Range("D5").Text
If num = "" Then
MsgBox "La celda D5 no contiene datos", vbExclamation
l2.Close False
Exit Sub
End If
If IsNumeric(num) Then
num = "" & Val(num)
End If
'
existe = False
For Each h In l1.Sheets
If h.Name = num Then
existe = True
Set h1 = h
Exit For
End If
Next
'
If existe = False Then
l1.Sheets.Add after:=l1.Sheets(l1.Sheets.Count)
Set h1 = l1.ActiveSheet
h1.Name = num
End If
'
uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If uc < Columns("F").Column Then uc = Columns("F").Column
h2.Range("O42:O99").Copy h1.Cells(1, uc)
l2.Close False
l1.Save
Application.ScreenUpdating = True
MsgBox "Copia realizada", vbInformation
End SubCrea una nueva pregunta para la última petición.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
