Realizado

Programación en Vba Excel

Publicado em 04 de Julho de 2020 dias na TI e Programação

Sobre este projeto

Aberto

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

Categoria TI e Programação
Subcategoria Outros
Tamanho do projeto Pequeño
Isso é um projeto ou uma posição de trabalho? Um projeto
Tenho, atualmente Eu tenho uma ideia geral
Disponibilidade requerida Conforme necessário
Integrações de API Outros (Outras APIs)

Prazo de Entrega: 06 de Julho de 2020

Habilidades necessárias

Outro projetos publicados por G.