Macro de Excel, que permita copiar datos de varias hojas a una sola
Necesito ayuda con macro que permita copiar varios datos de diferentes hojas a una sola hoja. Tengo un libro con varias hojas llenas de datos, pero solo quiero copiar los valores ubicados en unas celdas determinadas, que en este caso seria A2, B2 y C2; además si la celda C3 tiene valor también copiarlo en la siguiente fila, es decir, los datos deben quedar de la siguiente forma:
n1 ; n2 ; n3 - "Encabezado de la tabla"
A2 ; B2 ; C2 - "Datos de la Hoja 1"
A2 ; B2 ; C3 - "Datos de la Hoja 1, ya que C3 no esta vacío"
A2 ; B2 ; C2 - "Datos la Hoja 2"
Hasta ahora pensé que lo tenia resuelto utilizando esta macro, pero solo llena los encabezados, no se donde está el error, o si existe una forma mas sencilla de hacerlos. Así que agradezco la ayuda que me puedan dar. Voy a dejar un archivo de ejemplo, por si no entienden.
Sub ExtDatos()
Dim i As Long
Dim BuscarHoja As Boolean
On Error Resume Next
BuscarHoja = (Worksheets("Datos").Name <> "")
If BuscarHoja = False Then
Sheets.Add before:=Sheets(1)
End If
ActiveSheet.Name = "Datos"
Sheets("Datos").Activate
Sheets("Datos").Cells.Select
Selection.ClearContents
Sheets("Datos").Range("A1").Value = "n1"
Sheets("Datos").Range("B1").Value = "n2"
Sheets("Datos").Range("C1").Value = "n3"
For i = 2 To Sheets.Count
Sheets("Datos").Range("A1").End(xlDown).Offset(1, 0).Value = Sheets(i).Range("A2").Value
Sheets("Datos").Range("A1").End(xlDown).Offset(0, 1).Value = Sheets(i).Range("B2").Value
Sheets("Datos").Range("A1").End(xlDown).Offset(0, 2).Value = Sheets(i).Range("C2").Value
If Sheets(i).Range("C3").Value > 0 Then
Sheets("Datos").Range("A1").End(xlDown).Offset(1, 0).Value = Sheets(i).Range("A2").Value
Sheets("Datos").Range("A1").End(xlDown).Offset(0, 1).Value = Sheets(i).Range("B2").Value
Sheets("Datos").Range("A1").End(xlDown).Offset(0, 2).Value = Sheets(i).Range("C3").Value
End If
Next i
End Sub
Prueba con esta macro
Sub copiar()
On Error Resume Next
Set H1 = Worksheets("datos")
BuscarHoja = (Worksheets("Datos").Name <> "")
If BuscarHoja = False Then Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Datos"
Set H1 = Worksheets("datos")
On Error GoTo 0
With H1
.Select
.Cells.Clear
.Range("A1").Resize(1, 3) = Array("N1", "N2", "N3")
End With
For Each HOJA In Worksheets
Control = UCase(HOJA.Name)
VALIDA = Control = "DATOS"
If VALIDA Then GoTo SIG
Set ORIGEN = Worksheets(Control).Range("A2").CurrentRegion
With ORIGEN
RO = .Rows.Count: CO = .Columns.Count
End With
Set DESTINO = H1.Range("A1").CurrentRegion
With DESTINO
R = .Rows.Count
Set DESTINO = .Rows(R + 1).Resize(RO, CO)
.Value = ORIGEN.Value
End With
SIG:
Next HOJA
End Sub
La macro anterior copia toda la información de las hojas, si lo que quieres es copiar la primera línea de caja hoja, a2, b2, c2 entonces esta es la macro
Sub copiar()
On Error Resume Next
Set H1 = Worksheets("datos")
BuscarHoja = (Worksheets("Datos").Name <> "")
If BuscarHoja = False Then Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Datos"
Set H1 = Worksheets("datos")
On Error GoTo 0
With H1
.Select
.Cells.Clear
.Range("A1").Resize(1, 3) = Array("N1", "N2", "N3")
End With
For Each HOJA In Worksheets
Control = UCase(HOJA.Name)
VALIDA = Control = "DATOS"
If VALIDA Then GoTo SIG
Set origen = Worksheets(Control).Range("A2").CurrentRegion
With origen
RO = .Rows.Count: CO = .Columns.Count
Set origen = .Rows(1).Resize(1, 3)
End With
Set DESTINO = H1.Range("A1").CurrentRegion
With DESTINO
R = .Rows.Count
Set DESTINO = .Rows(R + 1).Resize(1, 3)
.Value = origen.Value
.EntireColumn.AutoFit
End With
SIG:
Next HOJA
End Sub
1 respuesta más de otro experto
:)
Lo siguiente te puede ser de utilidad:
Sub ExtDatos()
Dim i%, ws As Worksheet
On Error Resume Next
Set ws = Worksheets("Datos")
If Err.Number <> 0 Then Set ws = Worksheets.Add
On Error GoTo 0
With ws: .Name = "Datos": .Move Before:=Sheets(1): .Cells.Clear
.Range("a1:d1") = Array("n1", "n2", "n3", "Origen"): End With
For i = 2 To Worksheets.Count
With Worksheets(i)
ws.Cells(.Rows.Count, "a").End(xlUp).Range("a2:d2") = Array(.[a2], .[b2], .[c2], "hoja " & .Name)
If .[c3] <> "" Then
ws.Cells(.Rows.Count, "a").End(xlUp).Range("a2:d2") = Array(.[a2], .[b2], .[c3], "hoja " & .Name)
End If
End With
Next
End SubSaludos, Mario (Cacho) Rodríguez