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

Respuesta
1

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas