Copiar en hoja nueva y crear siempre la columna B para copiar datos
Tengo el siguiente código que realiza lo siguiente:
-Copia de un libro a otro en función de una celda.
-Si la hoja no existe el crea la hoja.
-Una vez que crea la hoja copia los datos de una hoja oculta.
En este código la copia de la nueva información siempre la hace en la siguiente columna, es decir si existe información en la columna C la copia en la D.
Quisiera que por favor me ayuden para que siempre que copie nueva información cree la columna B y se copia en la nueva columna a partir de la fila 8.
De antemano muchas gracias.
'Copiar informacion de Reporte a Bitacora
Sub Copiar_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
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
'copia de columna A de Hoja Datos
Sheets("Datos").Visible = True
Sheets("Datos").Columns("A").Copy h1.Columns("A")
Sheets("Datos").Visible = False
h1.Name = Num
End If
'
uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If uc < Columns("B").Column Then uc = Columns("B").Column
h2.Range("O42:O104").Copy h1.Cells(1, uc)
'ajusta columnas de B en adelante a 30
h1.Columns.ColumnWidth = 30
h1.Columns("A:A").EntireColumn.AutoFit
l2.Close False
l1.Save
Application.ScreenUpdating = True
MsgBox "Copia realizada", vbInformation
End Sub
1 respuesta
Te anexo la macro actualizada
'Copiar informacion de Reporte a Bitacora
Sub Copiar_adjuntos()
'Act.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
'copia de columna A de Hoja Datos
Sheets("Datos").Visible = True
Sheets("Datos").Columns("A").Copy h1.Columns("A")
'Sheets("Datos").Visible = False
h1.Name = Num
End If
'
'uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
'If uc < Columns("B").Column Then uc = Columns("B").Column
'h2.Range("O42:O104").Copy h1.Cells(1, uc)
h1.Columns("B").Insert
h2.Range("O42:O104").Copy h1.Cells(1, "B")
'ajusta columnas de B en adelante a 30
h1.Columns.ColumnWidth = 30
h1.Columns("A:A").EntireColumn.AutoFit
l2.Close False
l1.Save
Application.ScreenUpdating = True
MsgBox "Copia realizada", vbInformation
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Muchas gracias por tu ayuda, Solo una cosa más, Como puedo hacer para que la información se pegue en la nueva columna creada se pegue siempre a partir de la fila B8.
Muchas gracias.
Cambia esta línea
H2. Range("O42:O104"). Copy h1. Cells(1, "B")Por esta
H2. Range("O42:O104"). Copy h1.Cells(8, "B")sal u dos
