Run Same Macro on Different sheets

S

Smilin

Board Regular
Joined
Nov 28, 2019
Messages
67
Platform
  1. Windows
Using this Macro

How do I get this macro to work on current active sheet. I have workbook with several tabs and I want run the same macro based on which tab I am on. The link above is to the macro I need to run, however the path needs to be changed. The information will in tab will be in the same format. The path will always be from "hail" but the "macro" needs to be changed to which ever tab I am on. Please see my uploaded workbook which contains the tabs and the "hail" sheet . Gofile - Free file sharing and storage platform. Thank you :)
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
If you are referring to post #25 in that thread that you mentioned, have you tried replacing all of the 'Worksheets("Macro")' in the code with 'ActiveSheet.Name'
 
Upvote 0
See if this works like you want:

VBA Code: 
    Public DestinationSheet As Worksheet
    Public LastrowPlus1 As Long


Sub hailshort()
'
'   define source range
'
''    Set DestinationSheet = Worksheets("Macro")                                 ' <--- Set this to desired sheet
    Set DestinationSheet = Worksheets(ActiveSheet.Name)                     ' <--- Set this to desired sheet
'
    With DestinationSheet
        LastrowPlus1 = .Range("E" & Rows.Count).End(xlUp).Row + 1           ' Find LastRow of Column E on 'Macro' sheet and add 1 to the count
'
        Worksheets("hail").Range("N2:N17").Copy                             ' Copy N2:N17 from 'hail' sheet to 'macro' sheet Column C LastRowPlus1
        .Range("C" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("C2:C17").Copy                             ' Copy C2:C17 from 'hail' sheet to 'macro' sheet Column D LastRowPlus1
        .Range("D" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("E2:E17").Copy                             ' Copy E2:E17 from 'hail' sheet to 'macro' sheet Column E LastRowPlus1
        .Range("E" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("D2:D17").Copy                             ' Copy D2:D17 from 'hail' sheet to 'macro' sheet Column F LastRowPlus1
        .Range("F" & LastrowPlus1).PasteSpecial Paste:=xlValues
    End With
'
    Call sort
MsgBox "Done"
End Sub

Sub sort()
'
' sort Macro
'
    Application.CutCopyMode = False
'
    For RowOffset = LastrowPlus1 To LastrowPlus1 + 14 Step 2
        Range("J" & RowOffset) = "x"
    Next
'
    DestinationSheet.sort.SortFields.Clear
'
    DestinationSheet.sort.SortFields.Add Key:=Range("J" & LastrowPlus1 & ":J" & LastrowPlus1 + 16), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'
    With DestinationSheet.sort
        .SetRange Range("C" & LastrowPlus1 - 1 & ":J" & LastrowPlus1 + 16)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'
    Range("K" & LastrowPlus1 & ":K" & LastrowPlus1 + 15).Borders.LineStyle = xlNone             ' Fix Column K borders
'
    Range("J" & LastrowPlus1 & ":J" & LastrowPlus1 + 7).ClearContents
'
    With Range("D" & LastrowPlus1 & ":D" & LastrowPlus1 + 15)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 2
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'
    Range("F" & LastrowPlus1 & ":F" & LastrowPlus1 + 15).NumberFormat = "[<=9999999]###-####;(###) ###-####"
'
    With Range("H" & LastrowPlus1 & ":H" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
    End With
'
    Range("B" & LastrowPlus1).Select
    ActiveCell.FormulaR1C1 = "8:00 AM"
    Range("B" & LastrowPlus1).AutoFill Destination:=Range("B" & LastrowPlus1 & ":B" & LastrowPlus1 + 3), Type:=xlFillDefault
'
    Range("B" & LastrowPlus1 + 4).Select
    ActiveCell.FormulaR1C1 = "1:00 PM"
    Range("B" & LastrowPlus1 + 4).AutoFill Destination:=Range("B" & LastrowPlus1 + 4 & ":B" & LastrowPlus1 + 7), Type:=xlFillDefault
'
    Range("B" & LastrowPlus1 + 4 & ":B" & LastrowPlus1 + 7).Select
    Range("B" & LastrowPlus1 & ":B" & LastrowPlus1 + 7).Copy
'
    Range("B" & LastrowPlus1 + 8).Select
    ActiveSheet.Paste
'
    Application.CutCopyMode = False
'
    With Range("B" & LastrowPlus1 & ":G" & LastrowPlus1 + 7).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15071487
    End With
'
    With Range("B" & LastrowPlus1 + 8 & ":G" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15648990
    End With
'
    Range("E" & LastrowPlus1 + 19).Select
    With Range("A" & LastrowPlus1 & ":A" & LastrowPlus1 + 7).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15071487
    End With
'
    With Range("A" & LastrowPlus1 + 8 & ":A" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15648990
    End With
'
    Set CellRangeToAddBordersTo = Range("A" & LastrowPlus1 & ":I" & LastrowPlus1 + 15)
'
    For Each Cel In CellRangeToAddBordersTo
        With Cel.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
    Next
'
    Range("E" & LastrowPlus1 + 23).Select
End Sub
 
Upvote 0
Solution
johnnyL said:
See if this works like you want:

VBA Code: 
    Public DestinationSheet As Worksheet
    Public LastrowPlus1 As Long


Sub hailshort()
'
'   define source range
'
''    Set DestinationSheet = Worksheets("Macro")                                 ' <--- Set this to desired sheet
    Set DestinationSheet = Worksheets(ActiveSheet.Name)                     ' <--- Set this to desired sheet
'
    With DestinationSheet
        LastrowPlus1 = .Range("E" & Rows.Count).End(xlUp).Row + 1           ' Find LastRow of Column E on 'Macro' sheet and add 1 to the count
'
        Worksheets("hail").Range("N2:N17").Copy                             ' Copy N2:N17 from 'hail' sheet to 'macro' sheet Column C LastRowPlus1
        .Range("C" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("C2:C17").Copy                             ' Copy C2:C17 from 'hail' sheet to 'macro' sheet Column D LastRowPlus1
        .Range("D" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("E2:E17").Copy                             ' Copy E2:E17 from 'hail' sheet to 'macro' sheet Column E LastRowPlus1
        .Range("E" & LastrowPlus1).PasteSpecial Paste:=xlValues
'
        Worksheets("hail").Range("D2:D17").Copy                             ' Copy D2:D17 from 'hail' sheet to 'macro' sheet Column F LastRowPlus1
        .Range("F" & LastrowPlus1).PasteSpecial Paste:=xlValues
    End With
'
    Call sort
MsgBox "Done"
End Sub

Sub sort()
'
' sort Macro
'
    Application.CutCopyMode = False
'
    For RowOffset = LastrowPlus1 To LastrowPlus1 + 14 Step 2
        Range("J" & RowOffset) = "x"
    Next
'
    DestinationSheet.sort.SortFields.Clear
'
    DestinationSheet.sort.SortFields.Add Key:=Range("J" & LastrowPlus1 & ":J" & LastrowPlus1 + 16), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'
    With DestinationSheet.sort
        .SetRange Range("C" & LastrowPlus1 - 1 & ":J" & LastrowPlus1 + 16)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'
    Range("K" & LastrowPlus1 & ":K" & LastrowPlus1 + 15).Borders.LineStyle = xlNone             ' Fix Column K borders
'
    Range("J" & LastrowPlus1 & ":J" & LastrowPlus1 + 7).ClearContents
'
    With Range("D" & LastrowPlus1 & ":D" & LastrowPlus1 + 15)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 2
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'
    Range("F" & LastrowPlus1 & ":F" & LastrowPlus1 + 15).NumberFormat = "[<=9999999]###-####;(###) ###-####"
'
    With Range("H" & LastrowPlus1 & ":H" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
    End With
'
    Range("B" & LastrowPlus1).Select
    ActiveCell.FormulaR1C1 = "8:00 AM"
    Range("B" & LastrowPlus1).AutoFill Destination:=Range("B" & LastrowPlus1 & ":B" & LastrowPlus1 + 3), Type:=xlFillDefault
'
    Range("B" & LastrowPlus1 + 4).Select
    ActiveCell.FormulaR1C1 = "1:00 PM"
    Range("B" & LastrowPlus1 + 4).AutoFill Destination:=Range("B" & LastrowPlus1 + 4 & ":B" & LastrowPlus1 + 7), Type:=xlFillDefault
'
    Range("B" & LastrowPlus1 + 4 & ":B" & LastrowPlus1 + 7).Select
    Range("B" & LastrowPlus1 & ":B" & LastrowPlus1 + 7).Copy
'
    Range("B" & LastrowPlus1 + 8).Select
    ActiveSheet.Paste
'
    Application.CutCopyMode = False
'
    With Range("B" & LastrowPlus1 & ":G" & LastrowPlus1 + 7).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15071487
    End With
'
    With Range("B" & LastrowPlus1 + 8 & ":G" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15648990
    End With
'
    Range("E" & LastrowPlus1 + 19).Select
    With Range("A" & LastrowPlus1 & ":A" & LastrowPlus1 + 7).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15071487
    End With
'
    With Range("A" & LastrowPlus1 + 8 & ":A" & LastrowPlus1 + 15).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 15648990
    End With
'
    Set CellRangeToAddBordersTo = Range("A" & LastrowPlus1 & ":I" & LastrowPlus1 + 15)
'
    For Each Cel In CellRangeToAddBordersTo
        With Cel.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
'
        With Cel.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .Weight = xlThin
        End With
    Next
'
    Range("E" & LastrowPlus1 + 23).Select
End Sub
Click to expand...
 
Upvote 0
This works without a flaw. Thank you Johnny for your perseverance. :) Much obliged.
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question
Looking to create VBA command to go through List of sheet names, look up sheet name in range, look up value in cell next to it, and run a macro
Replies
3
Views
105
Volrin
V
S
  • Question
VBA for copying a range to new sheet in same workbook
Replies
1
Views
169
NoSparks
N
noisepoet
  • Solved
unprotect sheet via vba works first time, says incorrect password second time
Replies
3
Views
150
Fluff
Fluff
V
  • Question
Help Needed for a Macro to Transpose
Replies
6
Views
143
alansidman
A
GMC The Macro Man
  • Solved
VBA Script - Return to named file
Replies
6
Views
125
mumps
mumps

Forum statistics

Threads
1,215,004
Messages
6,122,656
Members
449,091
Latest member
peppernaut

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top