+ Reply to Thread
Results 1 to 5 of 5

Combining Macros

Hybrid View

rocketboy13 Combining Macros 11-30-2011, 06:13 PM
JBeaucaire Re: Combining Macros 11-30-2011, 06:21 PM
tigeravatar Re: Combining Macros 11-30-2011, 06:22 PM
rocketboy13 Re: Combining Macros 12-01-2011, 02:09 PM
JBeaucaire Re: Combining Macros 12-01-2011, 02:45 PM
  1. #1
    Registered User
    Join Date
    11-02-2011
    Location
    Washington, DC
    MS-Off Ver
    Excel 2007
    Posts
    6

    Combining Macros

    Hi,

    I have a series of macros shown below that I need to run one after the other. I want to be able to click a single button and then have all of them run in sequence. Can someone show me how they should be tied together?

    Thanks!

    Private Declare Function SetCurrentDirectoryA Lib _
        "kernel32" (ByVal lpPathName As String) As Long
    Sub ChDirNet(szPath As String)
        SetCurrentDirectoryA szPath
    End Sub
    Sub Combine_Util_CSV_Sheets()
        Dim MyPath As String
        Dim SourceRcount As Long, Fnum As Long
        Dim mybook As Workbook, BaseWks As Worksheet
        Dim sourceRange As Range, destrange As Range
        Dim rnum As Long, CalcMode As Long
        Dim SaveDriveDir As String
        Dim FName As Variant
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        SaveDriveDir = CurDir
        ChDirNet "C:\"
        FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                            MultiSelect:=True)
        If IsArray(FName) Then
            Set BaseWks = ActiveWorkbook.Worksheets(2)
            rnum = 1
            For Fnum = LBound(FName) To UBound(FName)
                Set mybook = Nothing
                On Error Resume Next
                Set mybook = Workbooks.Open(FName(Fnum))
                On Error GoTo 0
                If Not mybook Is Nothing Then
                    On Error Resume Next
                    With mybook.Worksheets(7)
                        Set sourceRange = .Range("A1:AD2000")
                    End With
                    If Err.Number > 0 Then
                        Err.Clear
                        Set sourceRange = Nothing
                    Else
            If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                            Set sourceRange = Nothing
                        End If
                    End If
                    On Error GoTo 0
                    If Not sourceRange Is Nothing Then
                        SourceRcount = sourceRange.Rows.Count
                        If rnum + SourceRcount >= BaseWks.Rows.Count Then
                            MsgBox "Not enough rows in the sheet. "
                            BaseWks.Columns.AutoFit
                            mybook.Close savechanges:=False
                            GoTo ExitTheSub
                        Else
                            Set destrange = BaseWks.Range("A" & rnum)
                            With sourceRange
                                Set destrange = destrange. _
                                                Resize(.Rows.Count, .Columns.Count)
                            End With
                            destrange.Value = sourceRange.Value
                            rnum = rnum + SourceRcount
                        End If
                    End If
                    mybook.Close savechanges:=False
                End If
            Next Fnum
            BaseWks.Columns.AutoFit
        End If
    ExitTheSub:
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With
        ChDirNet SaveDriveDir
    End Sub
    Sub Delete_Based_on_Criteria()
    
    Dim X As Long
    Dim Z As Long
    Dim LastRow As Long
    Dim FoundRowToDelete As Boolean
    Dim OriginalCalculationMode As Long
    Dim RowsToDelete As Range
    Dim SearchItems() As String
    
    Dim DataStartRow As Long
    Dim SearchColumn As String
    Dim SheetName As String
    
    DataStartRow = 2
    SearchColumn = "A"
    SheetName = "Sheet1"
    
    SearchItems = Split("Forecast")
    
    On Error GoTo Whoops
    OriginalCalculationMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    With Worksheets(SheetName)
    LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
    For X = LastRow To DataStartRow Step -1
    FoundRowToDelete = False
    For Z = 0 To UBound(SearchItems)
    If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
    FoundRowToDelete = True
    Exit For
    End If
    
    Next
    
    If FoundRowToDelete Then
    If RowsToDelete Is Nothing Then
    Set RowsToDelete = .Cells(X, SearchColumn)
    Else
    Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
    End If
    
    If RowsToDelete.Areas.Count > 100 Then
    RowsToDelete.EntireRow.Delete
    Set RowsToDelete = Nothing
    End If
    End If
    
    Next
    
    End With
    If Not RowsToDelete Is Nothing Then
    RowsToDelete.EntireRow.Delete
    End If
    
    Whoops:
    Application.Calculation = OriginalCalculationMode
    Application.ScreenUpdating = True
    
    
    End Sub
    
    Sub DeleteBlankRows()
    
    Dim R As Long
    Dim C As Range
    Dim n As Long
    Dim rng As Range
    
    On Error GoTo skip
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If Selection.Rows.Count > 1 Then
    Set rng = Selection
    Else
    Set rng = ActiveSheet.UsedRange.Rows
    End If
    n = 0
    For R = rng.Rows.Count To 1 Step -1
    If Application.WorksheetFunction.CountA(rng.Rows(R).EntireRow) = 0 Then
    rng.Rows(R).EntireRow.Delete
    n = n + 1
    End If
    Next R
    
    skip:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    End Sub
    
    Sub ClearNames()
    
        Range("E2:E36000").Select
        Selection.ClearContents
    
    End Sub

  2. #2
    Forum Expert JBeaucaire's Avatar
    Join Date
    03-21-2004
    Location
    Bakersfield, CA
    MS-Off Ver
    2010, 2016, Office 365
    Posts
    33,492

    Re: Combining Macros

    A new macro to run them in order:
    Sub MasterMacro()
    
       Call Combine_Util_CSV_Sheets
       Call Delete_Based_on_Criteria
       Call DeleteBlankRows
       Call ClearNames
    
    End Sub
    _________________
    Microsoft MVP 2010 - Excel
    Visit: Jerry Beaucaire's Excel Files & Macros

    If you've been given good help, use the icon below to give reputation feedback, it is appreciated.
    Always put your code between code tags. [CODE] your code here [/CODE]

    ?None of us is as good as all of us? - Ray Kroc
    ?Actually, I *am* a rocket scientist.? - JB (little ones count!)

  3. #3
    Forum Expert tigeravatar's Avatar
    Join Date
    03-25-2011
    Location
    Colorado, USA
    MS-Off Ver
    Excel 2003 - 2013
    Posts
    5,361

    Re: Combining Macros

    rocketboy13,

    If all you need is for them to run in sequence, you can assign the button to the following:
    Sub RunAll()
        Combine_Util_CSV_Sheets
        Delete_Based_on_Criteria
        DeleteBlankRows
        ClearNames
    End Sub


    Does that work for you?
    EDIT: Jerry beat me to it
    Last edited by tigeravatar; 11-30-2011 at 06:24 PM. Reason: Jerry beat me to it :)
    Hope that helps,
    ~tigeravatar

    Forum Rules: How to use code tags, mark a thread solved, and keep yourself out of trouble

  4. #4
    Registered User
    Join Date
    11-02-2011
    Location
    Washington, DC
    MS-Off Ver
    Excel 2007
    Posts
    6

    Re: Combining Macros

    Hadn't thought of that. Thanks, worked great.

  5. #5
    Forum Expert JBeaucaire's Avatar
    Join Date
    03-21-2004
    Location
    Bakersfield, CA
    MS-Off Ver
    2010, 2016, Office 365
    Posts
    33,492

    Re: Combining Macros

    If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1