Macro que me ayude a borrar el encabezado repetido
Necesito una macro que me ayude a borrar el encabezado repetido, ya que copiare varias tablas en una misma hoja, y deben quedar de manera seguida. Y solo debe aparecer el encabezado de la tabla al principio de la hoja.
1 respuesta
Como no especificas como están estructuradas tus tablas te hice este ejemplo funciona así, sobre la tabla que quieras copiar das crtl+e esto seleccionara todos los datos de esta tabla y luego corrers la macro, que hará lo siguiente: leerá la información y te pedirá que des click sobre la celda destino para obtener la ubicación donde copiara los datos si esta región no tiene encabezados copiara la información con todo encabezados, la segunda vez tabla haces lo mismo control E y te colocas al final de la fila de la tabla destino y corres de nuevo la macro volverá a buscar encabezados si los tiene entonces solo pegara los datos omitiendo los encabezados, este es el ejemplo de lo que menciono.
y esta es la macro
Sub copiar() Set datos = Selection With datos f = .Rows.Count: c = .Columns.Count End With Set mirango = Application.InputBox(prompt:="Click sobre celda destino", Type:=8) With mirango Set mirango = Range(mirango.Address).CurrentRegion fm = .Rows.Count: cm = .Columns.Count If fm = 1 And cm = 1 Then mirango.Resize(f, c).Value = datos.Value Else Set datos = datos.Rows(2).Resize(f - 1, c) mirango.Rows(fm).Resize(f - 1, c).Value = datos.Value End If End With End Sub
Si, hace lo que necesito. Solo un problema, como hago que corra al mismo tiempo que otra macro? La primera macro que tengo une diferentes archivos de excel en uno solo, y la segunda macro que me enviaste elimina el encabezado repetido. Ahora solo necesito que corra al mismo tiempo.
Aquí necesito ver tu macro y una imagen de la estructura de tu información para ver donde colocar el código o modificarlo para adaptarlo a lo que requieres.
Si, así es como llevo la macro.
'********Aplicacion Crea Reporte Final(*.xlsx) en un solo libro----------
Sub Open_Files()
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks.Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub
Sub Unir_Hojas()
Dim Sig As Byte, Eliminar As Boolean
For Sig = 2 To Worksheets.Count
Worksheets(Sig).UsedRange.Copy _
Worksheets(1).Range("a1000000").End(xlUp).Offset(1)
Next
Application.DisplayAlerts = False
For Sig = 2 To Worksheets.Count
Worksheets(2).Delete
Next
Application.DisplayAlerts = True
End Sub
Sub copiar() 'Para evitar que se repitan los encabezados de las tablas copiadas
Set datos = Selection
With datos
f = .Rows.Count: c = .Columns.Count
End With
Set mirango = Application.InputBox(prompt:="Click sobre celda destino", Type:=8)
With mirango
Set mirango = Range(mirango.Address).CurrentRegion
fm = .Rows.Count: cm = .Columns.Count
If fm = 1 And cm = 1 Then
mirango.Resize(f, c).Value = datos.Value
Else
Set datos = datos.Rows(2).Resize(f - 1, c)
mirango.Rows(fm).Resize(f - 1, c).Value = datos.Value
End If
End With
End Sub
Sub CambiarFormatoFecha() 'Cambia automaticamente los datos introducidos a las columnas B, y C, a Fechas
Dim i, k As String
i = "."
k = "/"
Columns("B").Replace what:=i,
Replacement:=k, lookat:=xlPart,
MatchCase: =False
Columns("C").Replace what:=i,
Replacement:=k, lookat:=xlPart,
MatchCase: =False
End Sub
Prueba esta macro, traslada todas las tablas que encuentre a la hoja 1 de un nuevo libro dejando solo los encabezados de la primera hoja que encuentre, por contra los datos deben tener la misma estructura.
Sub ABRIR_FILA() Dim X As Variant X = Application.GetOpenFilename _ ("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True) If IsArray(X) Then Workbooks.Add A = ActiveWorkbook.Name Set DESTINO = Workbooks(A).Worksheets("HOJA1") Z = 1 For Y = LBound(X) To UBound(X) Application.StatusBar = "Importando Archivos: " & X(Y) Workbooks.Open X(Y) B = ActiveWorkbook.Name For Each Hoja In Worksheets F = 0: C = 0 Set DATOS = Workbooks(B).Worksheets(Hoja.Name).UsedRange Selection.SpecialCells(xlCellTypeLastCell).Select Set DATOS = Selection.CurrentRegion F = DATOS.Rows.Count: C = DATOS.Columns.Count If F = 1 Then GoTo SIGUIENTE If Z = 1 Then Set DESTINO = DESTINO.Range("B2").Resize(F, C) Else Set DATOS = DATOS.Rows(2).Resize(F - 1, C) Set DESTINO = DESTINO.Rows(DESTINO.Rows.Count + 1).Resize(F - 1, C) End If DESTINO.Value = DATOS.Value Workbooks(B).Close False Z = Z + 1 SIGUIENTE: Next Hoja Next Y End If End Sub
- Compartir respuesta