Terminado

Programación en Vba Excel

Publicado el 04 Julio, 2020 en Programación y Tecnología

Sobre este proyecto

Abierto

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

Categoría Programación y Tecnología
Subcategoría Otros
Tamaño del proyecto Pequeño
¿Es un proyecto o una posición? Un proyecto
Actualmente tengo Tengo una idea
Disponibilidad requerida Según se necesite
Integraciones de API Otros (Otras APIs)

Plazo de Entrega: 06 Julio, 2020

Habilidades necesarias

Otros proyectos publicados por G.