Copiado de datos usando array para columnas origen y destino

Un favor me pudieran ayudar con lo siguiente

Quisiera obtener los resultados como se encuentran en el archivo "0 PD CARGA POL 20 07.Xlsm" Hoja "RECIB", los datos los debe de extraer del archivo "Recibidas_2020_08_Facturas.xlsx, trate de introducir las columnas en matriz sin embargo debido a que mi pc es lenta y manejo muchos datos fue la razón por la que decidí introducir mis columnas en matriz tanto las columnas que estoy copiando, así como las columnas de destino, sin embargo no lo hace correctamente, adjunto mi macro para cualquier apoyo, corrección de antemano, les agradezco

Sub Macro2()
'
Application.ScreenUpdating = False
Dim ws2, ws1 As Worksheet, Mat
Dim Q&
Set ws1 = ActiveSheet
ws2 = "Selecciona el libro a procesar"
MsgBox ws2, vbOKOnly
ws2 = Application.GetOpenFilename(Title:=ws2)
If ws2 = False Then Exit Sub
On Error GoTo 0
Set ws2 = Workbooks.Open(ws2)
Sheets("XML").Select
If [B2] = "" Then
MsgBox "Libro u Hoja sin Informacion."
 End If
'ReDim Matt(1 To 58)
Q = Range([B1], Cells(Rows.Count, "b").End(xlUp)).Rows.Count
colso = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF", "BG")
colsd = Array("A", "B", "D", "E", "F", "G", "H", "I", "J", "K", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF", "BG", "BH")
If [B2] <> "" Then
For col = LBound(colso) To UBound(colso)
For col2 = LBound(colsd) To UBound(colsd)
    Cells(2, colso(col)).Resize(Q).Copy
    ws1.Cells(4, colsd(col2)).Resize(Q).PasteSpecial xlPasteValues
  Next
Next
End If
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

1 respuesta

Respuesta
2

Prueba lo siguiente:

Sub Macro2()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim wb As Workbook
  Dim libro As Variant, colso As Variant, colsd As Variant
  Dim i As Long, lr As Long
  '
  Application.ScreenUpdating = False
  '
  Set ws1 = ActiveSheet
  libro = Application.GetOpenFilename(Title:="Selecciona el libro a procesar")
  If libro = False Then Exit Sub
  Set wb = Workbooks.Open(libro)
  Set ws2 = wb.Sheets("XML")
  colso = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", _
                "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", _
                "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", _
                "AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", _
                "BC", "BD", "BE", "BF", "BG")
  colsd = Array("A", "B", "D", "E", "F", "G", "H", "I", "J", "K", "M", "N", "O", "P", "Q", _
                "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE", _
                "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", "AQ", _
                "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", _
                "BD", "BE", "BF", "BG", "BH")
  '
  If ws2.[B2] = "" Then
    MsgBox "Libro u Hoja sin Informacion."
    Exit Sub
  End If
  lr = ws2.Range("B" & Rows.Count).End(3).Row - 1
  '
  For i = 0 To UBound(colso)
    ws1.Range(colsd(i) & 4).Resize(lr).Value = ws2.Range(colso(i) & 2).Resize(lr).Value
  Next
  '
  Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas