Thread: How do you put a macro in a macro

Sub Macro1()
'
' Macro1 Macro
'

'
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]=R1C2,RC[-1],IF(RC[-2]=R3C2,RC[-1],0))"
    Range("D1").Select
    Selection.AutoFill Destination:=Range("D1:D44160")
    Range("D1:D44160").Select
    Selection.Copy
    Columns("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows2"
    Application.Run "'ASX Closing Prices.xlsm'!x"
    Application.Run "'ASX Closing Prices.xlsm'!x"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=(RC[-1]-R[1]C[-1])/R[1]C[-1]"
    Range("D1:D2").Select
    Selection.AutoFill Destination:=Range("D1:D27632")
    Range("D1:D27632").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows3"
    Columns("B:B").Select
    Selection.Style = "Percent"
    Columns("A:B").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range( _
        "B1:B56142"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A1:B56142")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

This is my main macro (above) and in this macro I have used some macros which are shown below.
I want to merge these two macros to create one macro, because at the moment I am creating a macro to run a macro - I was wondering if I could get the macro of the macros I am running and put it in my main macro

Sub DeleteBlankARows1()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
If Cells(r, 3) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub DeleteBlankARows2()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
If Cells(r, 3) = "0" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub DeleteBlankARows3()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(r, 1) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub x()
Dim rng1 As Variant, rng2 As Variant, totalRng As Variant, cell As Variant
Set rng1 = Worksheets("Sheet2").Range("B1")
Set rng2 = rng1.End(xlDown)
Set totalRng = Range(rng1, rng2)

For Each cell In totalRng
    If cell.Value = cell.Offset(1, 0).Value Then
        cell.Rows.EntireRow.Delete Shift:=xlUp
    End If
Next cell
End Sub

Hi drmix

You don't give us a lot to work with. You can insert this line of code in Macro1 anywhere you wish

Call DeleteBlankARows1

and it will execute the procedure DeleteBlankARows1 then return to Sub Macro1 at the point it was interrupted.

Is this your issue?

John

Hi drmix

It's late here and I'm going to bed. However I'll be happy to revisit this issue in the AM. In the meantime, please look at this link http://www.oaltd.co.uk/Indenter/Default.htm it'll help the readability of your code.

Also, in my opinion, keeping your code compartmentalized is a good approach. Calling procedures to do specific tasks works for me.

John

Is the DeleteBlankARows1 macro in the same workbook?

Hi drmix

I feel as if I'm missing the point of your question. However, if the answer to RoyUK's question is affirmative, then you can simply replace the line of code as follows:

 '    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"
    Call DeleteBlankARows1

The above would be my preference. However, if you only want one macro, you could modify the code as follows:

'    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim r As Long
        For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
            If Cells(r, 3) = "" Then Rows(r).Delete
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

As I said, I feel I'm off point.

John

Hi drmix

I'm still not clear on your question UNLESS you're asking if you can do this

Option Explicit
Sub Macro1()
'
' Macro1 Macro
'
'
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"
    Range("D1").Select
 
 
    '    ActiveCell.FormulaR1C1 = "=IF(RC[-2]=R1C2,RC[-1],IF(RC[-2]=R3C2,RC[-1],0))"
Sub DeleteBlankARows1()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim r As Long
        For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
            If Cells(r, 3) = "" Then Rows(r).Delete
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
 
 
Range("D1").Select
Selection.AutoFill Destination:=Range("D1:D44160")
Range("D1:D44160").Select
Selection.Copy
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("D:D").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows2"
Application.Run "'ASX Closing Prices.xlsm'!x"
Application.Run "'ASX Closing Prices.xlsm'!x"
Range("D1").Select
ActiveCell.FormulaR1C1 = "=(RC[-1]-R[1]C[-1])/R[1]C[-1]"
Range("D1:D2").Select
Selection.AutoFill Destination:=Range("D1:D27632")
Range("D1:D27632").Select
Selection.Copy
Columns("D:D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("B:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows3"
Columns("B:B").Select
Selection.Style = "Percent"
Columns("A:B").Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range( _
        "B1:B56142"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
    .SetRange Range("A1:B56142")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

If that's what you're asking, in a word "No", to the best of my knowledge (admittedly limited), can't be done. You can "Call" the procedure but cannot "Embed" the entire procedure. You cannot have

Sub DeleteBlankARows1()
'Your Code
End Sub

inside another procedure. Sorry if I was misunderstanding your question.

John

Hi drmix

I believe that's what I suggested here

'    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim r As Long
        For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
            If Cells(r, 3) = "" Then Rows(r).Delete
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Replacing this line of code (notice that it's commented out)

'    Application.Run "'ASX Closing Prices.xlsm'!DeleteBlankARows1"

with this

With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        Dim r As Long
        For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
            If Cells(r, 3) = "" Then Rows(r).Delete
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

I must be missing something terribly here and I apologize for that...we don't appear to be communicating.
John

Hi drmix

I REALLY DON"T LIKE working on code I can't test. Having said that, comment out this line of code

Dim r As Long

in the

two 3 macros

and see what happens.

John

Hi drmix

To help us help you refer to the error message. For example, you probably received a messgae like "Duplicate Declaration...". Refer to the error message so we know what's happening. This dosen't help

something to do with "dim r as long"

John

Hi all thankyou for your patience - so I have put in the codes and this is the error i get

Sub Macro1()
'
' Macro1 Macro
'

'
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    On Error Resume Next
    Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-2]=R1C2,RC[-1],IF(RC[-2]=R3C2,RC[-1],0))"
    Range("D1").Select
    Selection.AutoFill Destination:=Range("D1:D44160")
    Range("D1:D44160").Select
    Selection.Copy
    Columns("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    Dim r As Long
    For r = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
    If Cells(r, 3) = "0" Then Rows(r).Delete
    Next r
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    End With
    Dim rng1 As Variant, rng2 As Variant, totalRng As Variant, cell As Variant
    Set rng1 = Worksheets("Sheet2").Range("B1")
    Set rng2 = rng1.End(xlDown)
    Set totalRng = Range(rng1, rng2)

    For Each cell In totalRng
    If cell.Value = cell.Offset(1, 0).Value Then
        cell.Rows.EntireRow.Delete Shift:=xlUp
    End If
    Next cell
    Dim rng1 As Variant, rng2 As Variant, totalRng As Variant, cell As Variant
    Set rng1 = Worksheets("Sheet2").Range("B1")
    Set rng2 = rng1.End(xlDown)
    Set totalRng = Range(rng1, rng2)

    For Each cell In totalRng
    If cell.Value = cell.Offset(1, 0).Value Then
        cell.Rows.EntireRow.Delete Shift:=xlUp
    End If
    Next cell
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=(RC[-1]-R[1]C[-1])/R[1]C[-1]"
    Range("D1:D2").Select
    Selection.AutoFill Destination:=Range("D1:D27632")
    Range("D1:D27632").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:C").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    Dim r As Long
    For r = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
    If Cells(r, 1) = "" Then Rows(r).Delete
    Next r
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    End With
    Columns("B:B").Select
    Selection.Style = "Percent"
    Columns("A:B").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range( _
        "B1:B56142"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A1:B56142")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Compile error: Dupliate declaration in current scope

I have also attached my worksheet - hope this helps! =]