COPIAR COLUMNAS ESPECIFICAS DE UN LIBRO A OTRO

[William Meza]

Buenas tardes,

por favor podrían ayudarme con la siguiente macro que no he podido lograr dar una solución.

Esta macro lo acabo de copiar de la web ya que tiene todo lo que necesito, sin embargo tiene un pequeño detalle lo cual requiero me puedan ayudar. La macro marcha bien cuando realiza la primera copia, sin embargo, cuando se importa una segunda información la macro no logra copiar los datos en la fila continua... por favor podrían ayudarme a corregir ese detalle.

 

Gracias.

Dim Q&

Set ws1 = ActiveSheet

On Error Resume Next
  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, ReadOnly:=True).Sheets(1)
If [c12] = "" Then
  MsgBox "Libro sin información."
  GoTo Fin
End If

ReDim Mat(1 To 4)

Q = Range([a6], Cells(Rows.Count, "c").End(xlUp)).Rows.Count

Mat(1) = Application.Transpose(ws2.[a6].Resize(Q))
Mat(2) = Application.Transpose(ws2.[c6].Resize(Q))
Mat(3) = Application.Transpose(ws2.[d6].Resize(Q))
Mat(4) = Application.Transpose(ws2.[g6].Resize(Q))

ws1.[b3].Resize(Q, UBound(Mat)) = Application.Transpose(Mat)


Fin:
ws2.Parent.Close False
ws1.[a4].CurrentRegion.Columns.AutoFit
End Sub

[rolano]

Public Sub copiarWs()
Dim Q&

Set ws1 = ActiveSheet

On Error Resume Next
  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, ReadOnly:=True).Sheets(1)
If [c12] = "" Then
  MsgBox "Libro sin información."
  GoTo Fin
End If

ReDim Mat(1 To 4)

Q = Range([a6], Cells(Rows.Count, "c").End(xlUp)).Rows.Count

Mat(1) = Application.Transpose(ws2.[a6].Resize(Q))
Mat(2) = Application.Transpose(ws2.[c6].Resize(Q))
Mat(3) = Application.Transpose(ws2.[d6].Resize(Q))
Mat(4) = Application.Transpose(ws2.[g6].Resize(Q))

LastRow = ws1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ws1.Range("b" & LastRow).Resize(Q, UBound(Mat)) = Application.Transpose(Mat)
'ws1.[b3].Resize(Q, UBound(Mat)) = Application.Transpose(Mat)


Fin:
ws2.Parent.Close False
ws1.[a4].CurrentRegion.Columns.AutoFit
End Sub

Prueba con la modificación