Shorten Code and Loop help

Sikorsky27

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
40
Office Version
  1. 2016
Platform
  1. Windows
I have a long code that I just cant seem to shorten with my lack of experience... I am self-teaching myself and just reaching out for assistance. I am copying files on one sheet and spreading the info to two other sheets. I need it to start from Row 50 and end no more than 400 but also needs to loop to go to next row on all three worksheets

Sheets("Adding").Select
Range("B2:C2").Select
Selection.UnMerge
Range("B2").Select
Range("B2").Copy
ThisWorkbook.Worksheets("Tracker").Visible = True
Sheets("Tracker").Select
Range("A50").Select
ActiveSheet.Paste
ThisWorkbook.Worksheets("Data").Visible = True
Sheets("Data").Select
Range("A50").Select
ActiveSheet.Paste
Range("J50").Select
ActiveSheet.Paste
Range("K50:Q50").Value = "0"

Sheets("Adding").Select
Range("C3").Select
Range("C3").Copy
Sheets("Data").Select
Range("B50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C4").Select
Range("C4").Copy
Sheets("Data").Select
Range("C50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C5").Select
Range("C5").Copy
Sheets("Data").Select
Range("D50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C6").Select
Range("C6").Copy
Sheets("Data").Select
Range("E50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C7").Select
Range("C7").Copy
Sheets("Data").Select
Range("F50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C8").Select
Range("C8").Copy
Sheets("Data").Select
Range("G50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("C9").Select
Range("C9").Copy
Sheets("Data").Select
Range("H50").Select
ActiveSheet.Paste

Sheets("Adding").Select
Range("B2:C9").Select
Range("B2:C9").ClearContents
Range("C10").ClearContents
Range("B2:C2").Select
Selection.Merge

ThisWorkbook.Worksheets("Adding").Visible = False
ThisWorkbook.Worksheets("Tracker").Visible = True
ThisWorkbook.Worksheets("Deploy Tracker").Visible = True
ThisWorkbook.Worksheets("Data").Visible = True
ThisWorkbook.Worksheets("All Data.Formula").Visible = True
ThisWorkbook.Worksheets("Archive").Visible = True
ThisWorkbook.Worksheets("Tracker").Activate
End Sub

1.PNG what the information is going into to

2.PNGThis is on one page

3.PNGThis is on the other page
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
Hello Sikorsky27, welcome to the MrExcel Message Board!

It's not entirely clear to me what exactly your ultimate goal is, more details are needed for that. How does the desired process work step by step for instance?
I transformed your code into the code below, so both do exactly the same. This might be a starting point for you.
VBA Code: 
Sub Sikorsky27()

    Dim shtAdding   As Worksheet
    Dim shtData     As Worksheet
    Dim shtTracker  As Worksheet
    Dim i           As Long

    With ThisWorkbook
        Set shtAdding = .Worksheets("Adding")
        Set shtData = .Worksheets("Data")
        Set shtTracker = .Worksheets("Tracker")
    End With

    With shtAdding
        .Range("B2:C2").UnMerge
        
        With .Range("B2")
            .Copy Destination:=shtData.Range("A50")
            .Copy Destination:=shtData.Range("J50")
            .Copy Destination:=shtTracker.Range("A50")
        End With
        
        .Range("C3:C9").Copy
        shtData.Range("B50").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True

        .Range("B2:C9,C10").ClearContents
        .Range("B2:C2").Merge
    End With
    shtData.Range("K50:Q50").Value = "0"
    
    Application.CutCopyMode = False

    ThisWorkbook.Worksheets("Adding").Visible = False
    ThisWorkbook.Worksheets("Tracker").Visible = True
    ThisWorkbook.Worksheets("Deploy Tracker").Visible = True
    ThisWorkbook.Worksheets("Data").Visible = True
    ThisWorkbook.Worksheets("All Data.Formula").Visible = True
    ThisWorkbook.Worksheets("Archive").Visible = True
    ThisWorkbook.Worksheets("Tracker").Activate
End Sub
 
Upvote 0
GWteB said:
Hello Sikorsky27, welcome to the MrExcel Message Board!

It's not entirely clear to me what exactly your ultimate goal is, more details are needed for that. How does the desired process work step by step for instance?
I transformed your code into the code below, so both do exactly the same. This might be a starting point for you.
VBA Code: 
Sub Sikorsky27()

    Dim shtAdding   As Worksheet
    Dim shtData     As Worksheet
    Dim shtTracker  As Worksheet
    Dim i           As Long

    With ThisWorkbook
        Set shtAdding = .Worksheets("Adding")
        Set shtData = .Worksheets("Data")
        Set shtTracker = .Worksheets("Tracker")
    End With

    With shtAdding
        .Range("B2:C2").UnMerge
       
        With .Range("B2")
            .Copy Destination:=shtData.Range("A50")
            .Copy Destination:=shtData.Range("J50")
            .Copy Destination:=shtTracker.Range("A50")
        End With
       
        .Range("C3:C9").Copy
        shtData.Range("B50").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True

        .Range("B2:C9,C10").ClearContents
        .Range("B2:C2").Merge
    End With
    shtData.Range("K50:Q50").Value = "0"
   
    Application.CutCopyMode = False

    ThisWorkbook.Worksheets("Adding").Visible = False
    ThisWorkbook.Worksheets("Tracker").Visible = True
    ThisWorkbook.Worksheets("Deploy Tracker").Visible = True
    ThisWorkbook.Worksheets("Data").Visible = True
    ThisWorkbook.Worksheets("All Data.Formula").Visible = True
    ThisWorkbook.Worksheets("Archive").Visible = True
    ThisWorkbook.Worksheets("Tracker").Activate
End Sub
Click to expand...
That is wonderfully shortened thank you for your time and it works so much smoother. I just need it to go down to next line every time submit button is selected. Do you have that magic knowledge as well @GWteB?
 
Upvote 0
Sikorsky27 said:
That is wonderfully shortened thank you for your time and it works so much smoother. I just need it to go down to next line every time submit button is selected. Do you have that magic knowledge as well @GWteB?
Click to expand...
You would put the info into the "Adding" page and hit submit and it would disperse the information to all respected areas. Now I just need it to keep going down from 50 all the way up to 400.
 
Upvote 0
So the source area is the same every time, but on every submit the next blank row on the target sheet must be used to place the data, is this correct?
 
Upvote 0
GWteB said:
So the source area is the same every time, but on every submit the next blank row on the target sheet must be used to place the data, is this correct?
Click to expand...
Yes.... eventually there will be up to 400 sites I need to track... currently at 50 so next line after every submit
 
Upvote 0
How about ...

VBA Code: 
Sub Sikorsky27_r2()

    Const FIRSTROW As Long = 50

    Dim shtAdding   As Worksheet
    Dim shtData     As Worksheet
    Dim shtTracker  As Worksheet
    Dim i           As Long
    Dim NextRow     As Long

    With ThisWorkbook
        Set shtAdding = .Worksheets("Adding")
        Set shtData = .Worksheets("Data")
        Set shtTracker = .Worksheets("Tracker")
    End With

    With shtData
        NextRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        If NextRow < FIRSTROW Then
            NextRow = FIRSTROW
        End If
    End With

    With shtAdding
        .Range("B2:C2").UnMerge

        With .Range("B2")
            .Copy Destination:=shtData.Range("A" & NextRow)
            .Copy Destination:=shtData.Range("J" & NextRow)
            .Copy Destination:=shtTracker.Range("A" & NextRow)
        End With

        .Range("C3:C9").Copy
        shtData.Range("B" & NextRow).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True

        .Range("B2:C9,C10").ClearContents
        .Range("B2:C2").Merge
    End With
    shtData.Range("K" & NextRow & ":Q" & NextRow).Value = "0"

    Application.CutCopyMode = False

    ThisWorkbook.Worksheets("Adding").Visible = False
    ThisWorkbook.Worksheets("Tracker").Visible = True
    ThisWorkbook.Worksheets("Deploy Tracker").Visible = True
    ThisWorkbook.Worksheets("Data").Visible = True
    ThisWorkbook.Worksheets("All Data.Formula").Visible = True
    ThisWorkbook.Worksheets("Archive").Visible = True
    ThisWorkbook.Worksheets("Tracker").Activate
End Sub
 
Upvote 0
Solution
GWteB said:
How about ...

VBA Code: 
Sub Sikorsky27_r2()

    Const FIRSTROW As Long = 50

    Dim shtAdding   As Worksheet
    Dim shtData     As Worksheet
    Dim shtTracker  As Worksheet
    Dim i           As Long
    Dim NextRow     As Long

    With ThisWorkbook
        Set shtAdding = .Worksheets("Adding")
        Set shtData = .Worksheets("Data")
        Set shtTracker = .Worksheets("Tracker")
    End With

    With shtData
        NextRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        If NextRow < FIRSTROW Then
            NextRow = FIRSTROW
        End If
    End With

    With shtAdding
        .Range("B2:C2").UnMerge

        With .Range("B2")
            .Copy Destination:=shtData.Range("A" & NextRow)
            .Copy Destination:=shtData.Range("J" & NextRow)
            .Copy Destination:=shtTracker.Range("A" & NextRow)
        End With

        .Range("C3:C9").Copy
        shtData.Range("B" & NextRow).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True

        .Range("B2:C9,C10").ClearContents
        .Range("B2:C2").Merge
    End With
    shtData.Range("K" & NextRow & ":Q" & NextRow).Value = "0"

    Application.CutCopyMode = False

    ThisWorkbook.Worksheets("Adding").Visible = False
    ThisWorkbook.Worksheets("Tracker").Visible = True
    ThisWorkbook.Worksheets("Deploy Tracker").Visible = True
    ThisWorkbook.Worksheets("Data").Visible = True
    ThisWorkbook.Worksheets("All Data.Formula").Visible = True
    ThisWorkbook.Worksheets("Archive").Visible = True
    ThisWorkbook.Worksheets("Tracker").Activate
End Sub
Click to expand...
That nailed it my friend... You are amazing, thank you!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
271
offthelip
O
gheyman
  • Solved
Copy from one workbook to another (just format and values)
Replies
2
Views
413
gheyman
gheyman
S
  • Solved
Copy row 2 and paste it after last row of another worksheet
Replies
9
Views
855
rollis13
rollis13
P
  • Question
Help with Vba Code
Replies
3
Views
152
Coyotex3
C
J
  • Question
Macro for copying data from multiple sheets to a common sheet based on a cell value
Replies
0
Views
207
jmk15315
J

Forum statistics

Threads
1,214,668
Messages
6,120,825
Members
448,990
Latest member
rohitsomani

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