A ver quiero copiar una tabla de datos de un archivo excel a otro, he podido pegar la tabla tal cual de un archivo a otro, sin embargo no he podido definir un codigo que me permita trasladar solo ciertos de datos al otro archivo de excel, las consideraciones son las siguientes:
1.- El rango de inicio de la hoja 1 del archivo excel 1 es diferente, es diferente al rango de inicio de la hoja 2 del archivo 2.
2.- Se requiere copiar todos los datos de la hoja 1 del excel 1, excepto los que tienen fila vacias, a la hoja 2 del excel 2.
3.- He podido definir algunos codigo que estan mezclados en lo siguiente:
Private Sub Boton1_Click()
Dim ARCHIVODESTINO As New Excel.Workbook
Dim LIBRORIGEN1 As Worksheet
Dim LIBRORIGEN2 As Worksheet
Dim LIBRODESTINO1 As Worksheet
Dim LIBRODESTINO2 As Worksheet
Dim ROrigenInsumo As Range
Dim ROrigenTarea As Range
Dim RDestinoInsumo As Range
Dim RDestinoTarea As Range
Dim RInicialTarea As Range
Dim RInicialInsumo As Range
Dim RFinalTarea As Range
Dim RFinalInsumo As Range
Dim RindenInsumo As Range
Dim cell As Range
Dim Ruta As String
Dim x10 As New Excel.Application
Dim n, m, z, UltimaFilaInsumo, UltimaFilaTiempo As Long
'Dim f1, f2, FilaInsumo, Filatiempo As Integer
Dim erow, erow2 As Long
'MsgBox ("¿Desea Generar Datos?"), vbQuestion, vbYesNo = vbYes
UltimaFilaInsumo = ThisWorkbook.Worksheets("C8.-INSUMOS").Cells(10, "AX").Value
UltimaFilaTiempo = ThisWorkbook.Worksheets("C15.-TIEMPOS").Cells(5, "P").Value
'k = ThisWorkbook.Worksheets("C8.-INSUMOS").Cells(11, "BB").Value
'z = UltimaFilaInsumo - 13 - k
Ruta =
ActiveWorkbook.Path
Set ARCHIVODESTINO =
x10.Workbooks.Open(Ruta & "\
DATAPROJECT.xlsx")
Set LIBRORIGEN1 = ThisWorkbook.Worksheets("C8.-INSUMOS")
Set LIBRORIGEN2 = ThisWorkbook.Worksheets("C15.-TIEMPOS")
Set LIBRODESTINO1 = ARCHIVODESTINO.Worksheets("TAREAS")
Set LIBRODESTINO2 = ARCHIVODESTINO.Worksheets("INSUMOS")
Set RInicialTarea =
LIBRORIGEN2.Range("O11:W" & UltimaFilaTiempo)
' For Each RFinalTarea In RInicialTarea.SpecialCells(xlCellTypeVisible)
'
Debug.Print RFinalTarea.Address
'Next RFinalTarea
'Set RInicialInsumo =
LIBRORIGEN1.Range("BA14:BI" & UltimaFilaInsumo)
'For Each RFinalInsumo In RInicialInsumo.SpecialCells(xlCellTypeVisible)
'
Debug.Print RFinalInsumo.Address
'Next RFinalInsumo
'Set ROrigenTarea =
LIBRORIGEN2.Range("O11:W" & UltimaFilaTiempo)
Set RindenInsumo =
LIBRORIGEN1.Range("BA14:BA" & UltimaFilaInsumo)
'Set ROrigenInsumo =
LIBRORIGEN1.Range("BB14:BJ" & UltimaFilaInsumo)
'Set RDestinoTarea =
LIBRODESTINO1.Range("A2")
'Set RDestinoInsumo =
LIBRODESTINO2.Range("A2")
'
ROrigenTarea.Copy
'RDestinoTarea.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'RDestinoTarea.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True
'Application.CutCopyMode = False
'
ROrigenInsumo.Copy
'RDestinoInsumo.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'RDestinoInsumo.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True
'Application.CutCopyMode = False
With LIBRODESTINO2
For Each cell In RindenInsumo
If
cell.Value = 1 Then
MsgBox n =
cell.Row
Set ROrigenInsumo =
LIBRORIGEN1.Range("bb" & n & ":bj" & n)
rorigeninsumo.Copy
LIBRODESTINO2.Activate
erow =
LIBRODESTINO2.Range("B" &
Rows.Count).End(xlUp).Offset(1, 0).Row
Set RDestinoInsumo =
LIBRODESTINO2.Range("A" & erow & ":I" & erow)
RDestinoInsumo.Paste 'Special Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
'DoEvents
'ElseIf
LIBRORIGEN1.Range("BA" & n).Value = 2 Then
'GoTo False
End If
Next cell
End With
'With LIBRODESTINO2
'For n = 14 To 20
'If
LIBRORIGEN1.Range("BA" & n).Value = 1 Then
' Set ROrigenInsumo =
LIBRORIGEN1.Range("bb" & n & ":bj" & n)
'
rorigeninsumo.Copy
' LIBRODESTINO2.Activate
' erow =
LIBRODESTINO2.Range("B" &
Rows.Count).End(xlUp).Offset(1, 0).Row
' Set RDestinoInsumo =
LIBRODESTINO2.Range("A" & erow & ":I" & erow)
' RDestinoInsumo.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'Application.CutCopyMode = False
'DoEvents
'ElseIf
LIBRORIGEN1.Range("BA" & n).Value = 2 Then
'GoTo False
'End If
'Next n
'End With
'For n = 14 To UltimaFilaInsumo
'If
LIBRORIGEN1.Cells(n, 54).Value <> Empty Then
'With LIBRODESTINO2
'.Cells(n - 12, 1) =
LIBRORIGEN1.Cells(n, 53).Value
'.Cells(n - 12, 2) =
LIBRORIGEN1.Cells(n, 54).Value
'.Cells(n - 12, 3) =
LIBRORIGEN1.Cells(n, 55).Value
'.Cells(n - 12, 4) =
LIBRORIGEN1.Cells(n, 56).Value
'.Cells(n - 12, 5) =
LIBRORIGEN1.Cells(n, 57).Value
'.Cells(n - 12, 6) =
LIBRORIGEN1.Cells(n, 58).Value
'.Cells(n - 12, 7) =
LIBRORIGEN1.Cells(n, 59).Value
'.Cells(n - 12, 8) =
LIBRORIGEN1.Cells(n, 60).Value
'.Cells(n - 12, 9) =
LIBRORIGEN1.Cells(n, 61).Value
' End With
' End If
'Next n
' Set RDestinoInsumo =
LIBRODESTINO2.Range("A" & erow)
'LIBRODESTINO2.Activate
'RDestinoInsumo.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'End If
'Next n
'Application.CutCopyMode = False
'For n = 14 To UltimaFilaInsumo
'If
LIBRORIGEN1.Range("BB" & n).Value <> "" Then
'Range("ba" & n & ":bi" & n).Select
' erow =
LIBRODESTINO2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' Set RDestinoInsumo =
LIBRODESTINO2.Range("A" & erow)
'LIBRODESTINO2.Activate
'RDestinoInsumo.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'End If
'Next n
'Application.CutCopyMode = False
'For m = 11 To UltimaFilaTiempo
' If Cells(m, 17).Value <> "" Then
'
LIBRORIGEN2.Range("O14:W" & m).Copy
'
LIBRODESTINO1.Range("A" & m - 9).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
'
LIBRODESTINO1.Range("A" & m - 9).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True
'Application.CutCopyMode = False
'End If
'Next
MsgBox "!Datos Generados en dataproject!"
archivodestino.Save
ARCHIVODESTINO.Close
Set x10 = Nothing
Set ARCHIVODESTINO = Nothing
End Sub
Plazo de Entrega: 06 Julio, 2020