Como se pueden unificar macros

Necesito de su colaboración para unificar varias macros. Cada macro esta en un modulo.

1 Respuesta

Respuesta
1

H o l a:

De estas macros:

Sub importar()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\REPORTES\desbloqueos Noviembre.txt", _
        Destination:=Range("$A$1"))
        .Name = "desbloqueos Noviembre"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Dim n As Long 'nº filas
    Dim i As Long
    Dim Fila As String
     n = ActiveSheet.UsedRange.Rows.Count
     For i = n To 1 Step -1
     Fila = i & ":" & i
     If WorksheetFunction.CountA(Range(Fila)) = 0 Then
       Range("A" & i).EntireRow.Delete
     End If
     Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub
Sub borra1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.CutCopyMode = False
Dim Celda As Range
Dim palabra As String
Dim valida As String
Range("A1:A" & Columns("A:A").Range("A1048576").End(xlUp).Row).Select
    palabra = "0x"
    palabra = "*" & palabra & "*"
    valida = "Information"
        For Each Celda In Selection
            If Celda.Value Like palabra Then
                Celda.Select
                ActiveCell.EntireRow.Select
                ActiveCell.EntireRow.Delete
            End If
        Next Celda
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub
Sub borra2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.CutCopyMode = False
Dim Celda As Range
Dim palabra As String
Dim valida As String
Range("A1:A" & Columns("A:A").Range("A1048576").End(xlUp).Row).Select
    palabra = "The"
    palabra = "*" & palabra & "*"
    valida = "Information"
        For Each Celda In Selection
            If Celda.Value Like palabra Then
                Celda.Select
                ActiveCell.EntireRow.Select
                ActiveCell.EntireRow.Delete
            End If
        Next Celda
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub

Te anexo la macro unificada:

Sub MacroUnica()
'Por.Dante Amor
    Application.ScreenUpdating = False
    '
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\REPORTES\desbloqueos Noviembre.txt", _
        Destination:=Range("$A$1"))
        .Name = "desbloqueos Noviembre"
        .FieldNames = True: .RowNumbers = False: .FillAdjacentFormulas = False
        .PreserveFormatting = True: .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells: .SavePassword = False
        .SaveData = True: .AdjustColumnWidth = True: .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False: .TextFilePlatform = 65001
        .TextFileStartRow = 1: .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False: .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False: .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False: .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True: .Refresh BackgroundQuery:=False
    End With
    '
    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        If WorksheetFunction.CountA(Rows(i)) = 0 Then
            Rows(i).Delete
        ElseIf Cells(i, "A") Like "*0x*" Or _
           Cells(i, "A") Like "*The*" Or _
           Cells(i, "A") Like "*If*" Or _
           Cells(i, "A") Like "*S-1*" Then
            Rows(i).Delete
        ElseIf Cells(i, "A") <> "sosservicios" And Left(Cells(i, "A"), 3) = "SOS" Then
            Rows(i).Delete
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas