Extraer datos dentro de hoja con formato array

A los miembros de este foto, en una oportunidad el amigo Dante Amor, me brindo una macro, el cual permite extraer información de una columna o columnas especificas, en esta ocasión necesito extraer toda la información de dicha hoja es decir desde la Columna A hasta la AO, pero dicho macro solo me esta admitiendo desde la A hasta a la AB, faltando desde la AC a la AO, adjunto código:

Sub CopiarHojaMineral()
'Por.Dante Amor
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set h1 = Sheets("PLLA601")
hoja = "Billete"
ini = 1
fin = h1.Range("AO" & Rows.Count).End(xlUp).Row
'
For Each h In Sheets
If UCase(h.Name) = UCase(hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Sheets(hoja).Delete
End If
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h2.Name = hoja
'
cols = Array("A", "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")
j = 1
For i = LBound(cols) To UBound(cols)
h1.Range(cols(i) & ini & ":" & cols(i) & fin).Copy h2.Cells(1, j)
h1.Range(cols(i) & ini & ":" & cols(i) & fin).Copy
h2.Cells(1, j).PasteSpecial Paste:=xlPasteColumnWidths
h2.Cells(1, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next
'
For i = ini To fin
alto = h1.Cells(i, "A").RowHeight
h2.Cells(i, "A").RowHeight = alto
Next
MsgBox "Copia terminada"
End Sub

Y me esta emitiendo un error:

 h2.Cells(1, j).PasteSpecial Paste:=xlPasteValues

2 Respuestas

Respuesta
1

Prueba con esta macro, ya sea que quites filas columnas la macro se adapta a estos cambios

Sub copiar_info()
Set h1 = Worksheets("plla601"): Set origen = h1.Range("a1").CurrentRegion
With origen:    f = .Rows.Count: c = .Columns.Count: End With
On Error Resume Next:  EXISTE = (Worksheets("billete").Name <> ""):  On Error GoTo 0
If Not EXISTE Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "billete"
Else
    Sheets("billete").Select: Cells.Clear
End If
Set h2 = Worksheets("billete")
Set destino = h2.Range("a1").Resize(f, c)
destino.Value = origen.Value
End Sub

Buenos días James Bond, adjunto pantallazo del hoja Original (PLLA601) que necesito copiar.

Código Macro:

Sub CopiarHojaMineral()
'Por.Dante Amor
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set h1 = Sheets("PLLA601")
hoja = "Billete"
ini = 1
fin = h1.Range("AO" & Rows.Count).End(xlUp).Row
'
For Each h In Sheets
If UCase(h.Name) = UCase(hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Sheets(hoja).Delete
End If
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h2.Name = hoja
'
cols = Array("A", "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")
j = 1
For i = LBound(cols) To UBound(cols)
h1.Range(cols(i) & ini & ":" & cols(i) & fin).Copy h2.Cells(1, j)
h1.Range(cols(i) & ini & ":" & cols(i) & fin).Copy
h2.Cells(1, j).PasteSpecial Paste:=xlPasteColumnWidths
h2.Cells(1, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next
'
For i = ini To fin
alto = h1.Cells(i, "A").RowHeight
h2.Cells(i, "A").RowHeight = alto
Next
MsgBox "Copia terminada"
End Sub

Resultado al ser ejecutada la macro linea arriba

Falta completar:

Y con la macro que me brindaste deja la hoja en blanco o quizas estoy realizando algo mal y si me brindas tu email, podría enviarte el archivo para mejor comprensión.

Saludos.

La macro esta bien, solo faltaba adaptarla al rango de tus datos,

esta es la macro ya adaptada

Sub copiar_info()
Dim ORIGEN As Range:    Dim DESTINO As Range
Set h1 = Worksheets("plla601"): Set ORIGEN = h1.Range("B5").CurrentRegion
With ORIGEN:    F = .Rows.Count: C = .Columns.Count: End With
On Error Resume Next:  EXISTE = (Worksheets("billete").Name <> ""):  On Error GoTo 0
If Not EXISTE Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "billete"
Else
    Sheets("billete").Select: Cells.Clear
End If
Set h2 = Worksheets("billete")
Set DESTINO = h2.Range("A5").Resize(F, C)
ORIGEN.Copy: DESTINO.PasteSpecial xlPasteAllUsingSourceTheme
MsgBox ("COPIA REALIZADA"), vbInformation, "AVISO"
End Sub

Buenas noches amigos James Bond / Dante Amor, agradeciéndoles por sus aporte brindado, ya que dichas macro están trabajando como se requería.

¡Gracias! 

Respuesta
1

La idea de copiar las columnas una por una, era copiar solamente algunas columnas, pero si vas a copiar todas las columnas, entonces puedes copiar toda la hoja.

Prueba con la siguiente:

Sub Macro4()
    Set h1 = Sheets("PLLA601")
    Set h2 = Sheets("Billete")
    H2. Cells. Clear
    H1. Cells. Copy
    h2.Range("A1").PasteSpecial Paste:=xlPasteValues
    h2.Range("A1").PasteSpecial Paste:=xlPasteFormats
End Sub

Antes de ejecutar la macro asegúrate que existe la hoja "Billete"

Revisa y me comentas.

Buenas noches amigos James Bond / Dante Amor, agradeciéndoles por sus aporte brindado, ya que dichas macro están trabajando como se requería.

¡Gracias! 

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas