VBA to create a Loop for routine copy and paste to another Workbook

T

TheHack22

Board Regular
Joined
Feb 3, 2021
Messages
121
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
Hi All,

I have some copy and paste routines to specific worksheets. Here is my current code that is working well, but it's not the most efficient VBA. Can someone help me with a loop?



VBA Code: 
Sub CLASS_1_US()
    Sheets("CLASS 1 - US").Select
    Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
      
End Sub
Sub CLASS_2_US()
Sheets("CLASS 2 - US").Select
    Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_3_US()
Sheets("CLASS 3 - US").Select
    Range("J2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_4_US()
Sheets("CLASS 4 - US").Select
    Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_6_US()
Sheets("CLASS 6 - US").Select
    Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_9_US()
Sheets("CLASS 9 - US").Select
    Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_1_INTL()
    Sheets("CLASS 1 - INTL").Select
     Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
  
End Sub
Sub CLASS_2_INTL()
    Sheets("CLASS 2 - INTL").Select
     Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_3_INTL()
    Sheets("CLASS 3 - INTL").Select
     Range("J2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_4_INTL()
    Sheets("CLASS 4 - INTL").Select
     Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub CLASS_6_INTL()
    Sheets("CLASS 6 - INTL").Select
     Range("L2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
  
End Sub
Sub MasterFillDownTemplate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Call CLASS_1_US
    Call CLASS_2_US
    Call CLASS_3_US
    Call CLASS_4_US
    Call CLASS_6_US
    Call CLASS_9_US
    Call CLASS_1_INTL
    Call CLASS_2_INTL
    Call CLASS_3_INTL
    Call CLASS_4_INTL
    Call CLASS_6_INTL
  
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "All Formulas copied and pasted"
End Sub

Imran
 
Last edited by a moderator:

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Here is a shortened version, see if this works properly for you:

VBA Code: 
Sub MasterFillDownTemplate()
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
    Sheets("CLASS 1 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - US").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 9 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 1 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - INTL").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    MsgBox "All Formulas copied and pasted"
End Sub


Sub CommonCode()
'
    Range(Selection, Selection.End(xlToRight)).Copy
'
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
'
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub
 
Upvote 0
Solution
johnnyL said:
Here is a shortened version, see if this works properly for you:

VBA Code: 
Sub MasterFillDownTemplate()
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
    Sheets("CLASS 1 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - US").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 9 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 1 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - INTL").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    MsgBox "All Formulas copied and pasted"
End Sub


Sub CommonCode()
'
    Range(Selection, Selection.End(xlToRight)).Copy
'
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
'
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub
Click to expand...
@jonnyL

Thanks very much. I'll test this tomorrow at work and provide some feedback. This is so organized and clear for a layman like me to understand.

Imran
 
Upvote 0
johnnyL said:
Here is a shortened version, see if this works properly for you:

VBA Code: 
Sub MasterFillDownTemplate()
'
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'
    Sheets("CLASS 1 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - US").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 9 - US").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 1 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 2 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 3 - INTL").Select
    Range("J2").Select
    Call CommonCode
'
    Sheets("CLASS 4 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Sheets("CLASS 6 - INTL").Select
    Range("L2").Select
    Call CommonCode
'
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
'
    MsgBox "All Formulas copied and pasted"
End Sub


Sub CommonCode()
'
    Range(Selection, Selection.End(xlToRight)).Copy
'
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
'
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub
Click to expand...
@johnnyL

Thanks so much. This works perfectly.
Imran
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA to Save a New File to One Drive
Replies
2
Views
111
Logit
Logit
E
  • Solved
macro for copying values to the next blank cell
Replies
5
Views
912
Micron
M
V
  • Question Question
Macro / VBA help
Replies
3
Views
102
Logit
Logit
D
  • Solved
VBA If statement to continue
2
Replies
17
Views
777
dinunan
D
D
  • Solved
Trying to copy data from a specific sheet in one workbook to another with VBA
Replies
2
Views
312
druck21
D

Forum statistics

Threads
1,226,492
Messages
6,191,355
Members
453,656
Latest member
lilyrosy

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