Jump to content
William Meza

COPIAR COLUMNAS ESPECIFICAS DE UN LIBRO A OTRO

Recommended Posts

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

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now



×
×
  • Create New...

Important Information

Privacy Policy


CTA Templates.png