Shorten Code and Loop help

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
32
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

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
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
 

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
32
Office Version
  1. 2016
Platform
  1. Windows
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
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?
 

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
32
Office Version
  1. 2016
Platform
  1. Windows
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?
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.
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
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?
 

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
32
Office Version
  1. 2016
Platform
  1. Windows
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?
Yes.... eventually there will be up to 400 sites I need to track... currently at 50 so next line after every submit
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
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
 
Solution

Sikorsky27

New Member
Joined
Jun 24, 2021
Messages
32
Office Version
  1. 2016
Platform
  1. Windows
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
That nailed it my friend... You are amazing, thank you!!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
Glad it's sorted, thanks for letting me know.
 

Forum statistics

Threads
1,176,255
Messages
5,902,166
Members
434,945
Latest member
ngabrieln

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
Top