Macro para varias hojas con distinto nombre

Me hiciste esta macro, pero ahora tengo otra cosa,

Donde pone hoja = "180.3T", esa hoja puede tener varios nombres como por ejemplo, 180, 180.1t, 180.2t. 180. Ok. 3t, ¿Hay alguna manera que la macro se ejecute en todas las hojas? Lo que siempre tienen en común es 180

Como siempre agradecido estoy

Sub Resumen()

'Por.Dante Amor

    Application.Calculation = xlCalculationManual '==> esto me dice que es para que vaya mas rapido quitar si da error

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Set l1 = ThisWorkbook

    Set h1 = l1.Sheets("Resumen")

    h1.Rows("2:" & Rows.Count).Clear

    '

    'ruta = "C:\GENAR - ASESMAG17\CONTABILIDAD 2017\ALFONSO CONTABILIDAD 2017\"

    ruta = ThisWorkbook.Path & "\"

    arch = Dir(ruta & "*.xls*")

    hoja = "180.3T"

    j = 2

    Do While arch <> ""

        If arch <> l1.Name Then

            Set l2 = Workbooks.Open(ruta & arch)

            existe = False

            For Each h In l2.Sheets

                If UCase(h.Name) = hoja Then

                    existe = True

                    Exit For

                End If

            Next

            If existe = True Then

                Set h2 = l2.Sheets(hoja)

 'ES PARA QUE LO COPIE COMO VALOR EN LA HOJA DE 180

       Cells.Select

    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

 '====================================================

                For i = 3 To 30

                    If h2.Cells(i, "G") <> 0 Then

                        h2.Rows(i).Copy h1.Rows(j)

                        h1.Cells(j, "AA") = h2.Range("B1")

                        j = j + 1

                    End If

                Next

            End If

            l2.Close False

        End If

        j = j + 1

        arch = Dir()

    Loop

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationAutomatic '==> esto me dice que es para que vaya mas rapido quitar si da error

    MsgBox " Resumen terimado ", vbInformation, "RESUMEN"

End Sub

1 respuesta

Respuesta
1

Envíame tu archivo con unos ejemplos para hacer pruebas

Te anexo la macro

Sub Resumen()
'Por.Dante Amor
    Application.Calculation = xlCalculationManual '==> esto me dice que es para que vaya mas rapido quitar si da error
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Resumen")
    h1.Rows("2:" & Rows.Count).Clear
    '
    'ruta = "C:\GENAR - ASESMAG17\CONTABILIDAD 2017\ALFONSO CONTABILIDAD 2017\"
    ruta = ThisWorkbook.Path & "\"
    arch = Dir(ruta & "*.xls*")
    hoja = "180"
    j = 2
    Do While arch <> ""
        If arch <> l1.Name Then
            Set l2 = Workbooks.Open(ruta & arch)
            existe = False
            For Each h In l2.Sheets
                If Left(UCase(h.Name), Len(hoja)) = hoja Then
                    existe = True
                    hoja_nombre = h.Name
                    Exit For
                End If
            Next
            If existe = True Then
                Set h2 = l2.Sheets(hoja_nombre)
                '
                'ES PARA QUE LO COPIE COMO VALOR EN LA HOJA DE 180
                'Cells.Select
                'Selection.Copy
                'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                '    :=False, Transpose:=False
                '====================================================
                For i = 3 To 30
                    If h2.Cells(i, "G") <> 0 Then
                        h2.Rows(i).Copy
                        h1.Rows(j).PasteSpecial xlValues
                        h1.Cells(j, "AA") = h2.Range("B1")
                        j = j + 1
                    End If
                Next
            End If
            l2.Close False
        End If
        j = j + 1
        arch = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic '==> esto me dice que es para que vaya mas rapido quitar si da error
    MsgBox " Resumen terminado ", vbInformation, "RESUMEN"
End Sub

.

. S aludos. Dante Amor. R ecuerda valorar la respuesta. G racias

.

¿Hay alguna opción para que no salga este mensaje que te pongo a continuación?

Y por ultimo que se me olvido decirte, ¿hay alguna manera en la macro de decirle que pare cuando llegue a la palabra FIN?, ya que a veces aunque yo le puesto el rango desde 3 a 30, necesito que pare antes, en concreto cuando aparezca la palabra FIN

Como siempre

Muchas gracias

Para lo de los vínculos, ve a opciones de excel, centro de confianza, configuración del centro de confianza, Contenido externo, y ahí selecciona las opciones: "Deshabilitar todas las conexiones de datos" y "Deshabilitar actualización automática de todos los vínculos del libro"

Después de esta línea:

For i = 3 To 30

Agrega esta línea

If h2.Cells(i, "G") = "FIN" Then Exit For

No olvides valorar la respuesta

Buenas, ¿pero con esta función deja en la hoja resumen los datos como valor? Es que de donde coge los datos está con fórmulas y los tiene que tiene que llevar a la hoja resumen como valor y dejar con el mismo formato y en la hoja de donde coge los datos se tiene que quedar con las fórmulas

Macro actualizada para pegar valores y formatos. La hoja original no se modifica, esa queda con sus fórmulas.

Sub Resumen()
'Por.Dante Amor
    Application.Calculation = xlCalculationManual '==> esto me dice que es para que vaya mas rapido quitar si da error
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Resumen")
    h1.Rows("2:" & Rows.Count).Clear
    '
    'ruta = "C:\GENAR - ASESMAG17\CONTABILIDAD 2017\ALFONSO CONTABILIDAD 2017\"
    ruta = ThisWorkbook.Path & "\"
    arch = Dir(ruta & "*.xls*")
    hoja = "180"
    j = 2
    Do While arch <> ""
        If arch <> l1.Name Then
            Set l2 = Workbooks.Open(ruta & arch)
            existe = False
            For Each h In l2.Sheets
                If Left(UCase(h.Name), Len(hoja)) = hoja Then
                    existe = True
                    hoja_nombre = h.Name
                    Exit For
                End If
            Next
            If existe = True Then
                Set h2 = l2.Sheets(hoja_nombre)
                '
                'ES PARA QUE LO COPIE COMO VALOR EN LA HOJA DE 180
                'Cells.Select
                'Selection.Copy
                'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                '    :=False, Transpose:=False
                '====================================================
                For i = 3 To 30
                    If h2.Cells(i, "G") <> 0 Then
                        h2.Rows(i).Copy
                        h1.Rows(j).PasteSpecial xlValues
                        h1.Rows(j).PasteSpecial xlPasteFormats
                        h1.Cells(j, "AA") = h2.Range("B1")
                        j = j + 1
                    End If
                Next
            End If
            l2.Close False
        End If
        j = j + 1
        arch = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic '==> esto me dice que es para que vaya mas rapido quitar si da error
    MsgBox " Resumen terminado ", vbInformation, "RESUMEN"
End Sub

.

. S aludos. Dante Amor. R ecuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas