Macros que me copie datos de mi libro de hojasα, β, γ…ω, todas ellas con el mismo formato. A un libro Excel diferente.
amig@s.
Esperando no molestarlos, debo mencionarles que tengo una macros, que me copia datos de una hojaα a otro libro de hoja@.
En lo que al inicio esta macros me pone como condición lo siguiente.
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("hojaα ") 'Hoja formato
Set l2 = Workbooks.Open("direcciondehoja")
Set h2 = l2.Sheets("hoja@.") 'Hoja destino
ThisWorkbook. Activate
Y debo decirles que si me resulta y bien. Pero me preguntaba si se puede editar de modo que, esta macros. No me pida la hoja de formato "hojaα ", ya que tengo muchas hojas con el mismo formato. Pero distintos nombres de hojasα, β, γ…ω
1 Respuesta
Te anexo la macro con el ajuste de la hoja, también con la instrucción para que no se vea como se abre y se cierra el archivo destino:
Los datos de libro y hoja destino, los ajustas en estas líneas
libro2 = "libro destino.xlsx"
y
Set h2 = l2.Sheets("HojaX") 'Hoja destinoSub Registrar()
'---
' Por.Dante Amor
'---
'
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet 'Hoja formato
'
libro2 = "libro destino.xlsx"
existe = False
For Each libros In Workbooks
If libros.Name = libro2 Then
existe = True
Exit For
End If
Next
'
If Not existe Then
If Dir(l1.Path & "\" & libro2) <> "" Then
Workbooks.Open l1.Path & "\" & libro2
existe = True
End If
End If
If existe = False Then
MsgBox "No existe el libro: " & libro2, vbCritical
Exit Sub
End If
'
Set l2 = Workbooks(libro2)
Set h2 = l2.Sheets("HojaX") 'Hoja destino
'
If h1.Range("H9").Value = "" Then
MsgBox "Falta la categoría", vbExclamation
Exit Sub
End If
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 15
Do While h1.Cells(i, "C") <> ""
'datos de cabecera
h2.Cells(u2, "A") = h1.[H9] 'categoría
h2.Cells(u2, "B") = h1.[H7] 'fecha emisión
h2.Cells(u2, "C") = h1.[G5] 'factrura
h2.Cells(u2, "D") = h1.[H5] 'de compra
h2.Cells(u2, "E") = h1.[H8] 'atención
'
'continuar en esta parte con los demás datos
'
'datos de detalle
H2.Cells(u2, "K") = h1. Cells(i, "C") 'num fila
h2.Cells(u2, "L") = h1. Cells(i, "D") 'cant
h2.Cells(u2, "M") = h1. Cells(i, "E") 'cant
h2.Cells(u2, "N") = h1. Cells(i, "F") 'desc
h2.Cells(u2, "O") = h1. Cells(i, "G") 'pu
h2.Cells(u2, "P") = h1. Cells(i, "H") 'importe
'
'datos de resumen
h2.Cells(u2, "Q") = h1.[H37] 'sub total
h2.Cells(u2, "R") = h1.[H38] 'iva
'
'Busca TOTAL
Set b = h1.Columns("G").Find("T O T A L", lookat:=xlWhole)
If Not b Is Nothing Then
h2.Cells(u2, "S") = h1.Range("H" & b.Row) 'total
End If
'
u2 = u2 + 1
i = i + 1
Loop
l2.Save 'guarda el libro2
l2.Close 'cierra el libro2
MsgBox "Datos Registrados"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
