Shrinking Code/Procedure Limit workarounds

P

PKDP

New Member
Joined
May 11, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Hello!
I am VERY new to VBA (started learning about 3 days ago) but have created a code to look at a bunch of different cells on different sheets, and if there is a value in that cell, it will copy 3 other different cells in the doc and paste it to a coversheet. (Creating a button for employee timesheets that will grab the job number, cost code, and number of hours).My issue tis that I will need this code to run 1024 times:oops:, which would make a little less the 9500 lines of code :eek::sick:. The main issue with all of that is that it obviously leads to an error for the procedure being too large. I'm trying to see if there is a way to streamline what I already have so that i can get this to run? Any help would be greatly appreciated!

Here is the code to reference 2 different cells, this process basically repeats over and over, but references different cells for the IF conditional, and the cells to be copied if the IF conditional is True.

VBA Code: 
Private Sub Ret_Click()
    If Not (IsEmpty(Sheet2.Range("C10"))) Then
        Sheets("TS TIME CARD").Range("C5").COPY
        Sheets("COVERSHEET").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Sheets("TS TIME CARD").Range("C10").COPY
        Sheets("COVERSHEET").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Sheets("TS TIME CARD").Range("A10").COPY
        Sheets("COVERSHEET").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Else
    End If
    If Not (IsEmpty(Sheet2.Range("D10"))) Then
        Sheets("TS TIME CARD").Range("D5").COPY
        Sheets("COVERSHEET").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Sheets("TS TIME CARD").Range("D10").COPY
        Sheets("COVERSHEET").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
        Sheets("TS TIME CARD").Range("A10").COPY
        Sheets("COVERSHEET").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Else
    End If
EndSub
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
How much you can simplify will depend on whether there is a pattern for the cells to check, but as a basic start you should be refactoring the main code into a separate routine and just pass arguments for the cells to copy - for example:

Code: 
Sub CopyValues(cellAddress1 as string, cellAddress2 as String)
        Dim TimeCardSheet as Worksheet
set timecardsheet = Sheets("TS TIME CARD")
dim coversheet as worksheet
set coversheet = Sheets("COVERSHEET")
coversheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Resize(, 3).Value = Array(timecardsheet.Range(cellAddress1).value , timecardsheet.Range(cellAddress2).value,timecardsheet.Range("A10").value)
End Sub

then:

Code: 
Private Sub Ret_Click()
    If Not (IsEmpty(Sheet2.Range("C10"))) Then CopyValues "C5", "C10"
    If Not (IsEmpty(Sheet2.Range("D10"))) Then CopyValues "D5", "D10"
End Sub

If it's just checking row 10 and always copying cells from rows 5 and 10 in the same column, you could put that into a simple loop.
 
Upvote 0
Solution
Thank you for your response! ill have to look at it in depth this evening to understand it better.
If it helps here is a quick VIDEO of the first sheet functioning properly.
What I am hoping to achieve is for this code to run through the first page, as well as the other sheets at the bottom since our employees may have hours worked in different departments. Thanks Again!
 
Upvote 0
Hello! first off Thank you again for this code! This solution semi worked. My first issue is that the code needs to run through multiple rows. So I made this adjustment. (Added cellAddress3 and included that in the second set of code)
VBA Code: 
Sub CopyValues(cellAddress1 As String, cellAddress2 As String, cellAddress3 As String)
        Dim TimeCardSheet As Worksheet
Set TimeCardSheet = Sheets("TS TIME CARD")
Dim coversheet As Worksheet
Set coversheet = Sheets("COVERSHEET")
coversheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Resize(, 3).Value = Array(TimeCardSheet.Range(cellAddress1).Value, TimeCardSheet.Range(cellAddress2).Value, TimeCardSheet.Range(cellAddress3).Value)
End Sub
Private Sub Ret_Click()
    If Not (IsEmpty(Sheet2.Range("C10"))) Then CopyValues "C5", "C10", "A10"
    If Not (IsEmpty(Sheet2.Range("D10"))) Then CopyValues "D5", "D10", "A10"
    If Not (IsEmpty(Sheet2.Range("E10"))) Then CopyValues "E5", "E10", "A10"
    If Not (IsEmpty(Sheet2.Range("F10"))) Then CopyValues "F5", "F10", "A10"
    If Not (IsEmpty(Sheet2.Range("G10"))) Then CopyValues "G5", "G10", "A10"
    If Not (IsEmpty(Sheet2.Range("H10"))) Then CopyValues "H5", "H10", "A10"
    If Not (IsEmpty(Sheet2.Range("I10"))) Then CopyValues "I5", "I10", "A10"
    If Not (IsEmpty(Sheet2.Range("J10"))) Then CopyValues "J5", "J10", "A10"
    If Not (IsEmpty(Sheet2.Range("K10"))) Then CopyValues "K5", "K10", "A10"
    If Not (IsEmpty(Sheet2.Range("L10"))) Then CopyValues "L5", "L10", "A10"
    If Not (IsEmpty(Sheet2.Range("M10"))) Then CopyValues "M5", "M10", "A10"
    If Not (IsEmpty(Sheet2.Range("N10"))) Then CopyValues "N5", "N10", "A10"
    If Not (IsEmpty(Sheet2.Range("O10"))) Then CopyValues "O5", "O10", "A10"
    If Not (IsEmpty(Sheet2.Range("P10"))) Then CopyValues "P5", "P10", "A10"
    If Not (IsEmpty(Sheet2.Range("Q10"))) Then CopyValues "Q5", "Q10", "A10"
    If Not (IsEmpty(Sheet2.Range("R10"))) Then CopyValues "R5", "R10", "A10"
    If Not (IsEmpty(Sheet2.Range("C12"))) Then CopyValues "C5", "C12", "A12"
    If Not (IsEmpty(Sheet2.Range("D12"))) Then CopyValues "D5", "D12", "A12"
    If Not (IsEmpty(Sheet2.Range("E12"))) Then CopyValues "E5", "E12", "A12"
    If Not (IsEmpty(Sheet2.Range("F12"))) Then CopyValues "F5", "F12", "A12"
    If Not (IsEmpty(Sheet2.Range("G12"))) Then CopyValues "G5", "G12", "A12"
    If Not (IsEmpty(Sheet2.Range("H12"))) Then CopyValues "H5", "H12", "A12"
    If Not (IsEmpty(Sheet2.Range("I12"))) Then CopyValues "I5", "I12", "A12"
    If Not (IsEmpty(Sheet2.Range("J12"))) Then CopyValues "J5", "J12", "A12"
    If Not (IsEmpty(Sheet2.Range("K12"))) Then CopyValues "K5", "K12", "A12"
    If Not (IsEmpty(Sheet2.Range("L12"))) Then CopyValues "L5", "L12", "A12"
    If Not (IsEmpty(Sheet2.Range("M12"))) Then CopyValues "M5", "M12", "A12"
    If Not (IsEmpty(Sheet2.Range("N12"))) Then CopyValues "N5", "N12", "A12"
    If Not (IsEmpty(Sheet2.Range("O12"))) Then CopyValues "O5", "O12", "A12"
    If Not (IsEmpty(Sheet2.Range("P12"))) Then CopyValues "P5", "P12", "A12"
    If Not (IsEmpty(Sheet2.Range("Q12"))) Then CopyValues "Q5", "Q12", "A12"
    If Not (IsEmpty(Sheet2.Range("R12"))) Then CopyValues "R5", "R12", "A12"

This runs all the way down through row 18.

The issue I'm having now is that I need this same thing to run through 5 other sheets in the same workbook. The initial sub routine specifically calls out a single sheet here is that code.
VBA Code: 
set timecardsheet = Sheets("TS TIME CARD")

Is there a way to make it run on the "TS TIME CARD " sheet and then continue on to the other sheets?
 
Upvote 0
It looks like that can be simplified further with a loop, and we can add the sheet as an additional argument. Is it the same cells on the other 5 sheets, and do they all go to the cover sheet?
 
Upvote 0
Yes they all go to the cover sheet, and the other sheets all go to at least row 18 Below are how far down the other 5 sheets go
Sheet2-row18 Sheet3-row36 Sheet4-row32 Sheet5, 6 , & 7 - row30
 
Upvote 0
If having them all run to the same end row (36) helps keep the file size smaller, could I also add some creative spacing so that each sheet can run the same sub routine?
 
Upvote 0
Here's an example of what may work better, assuming the pattern of copied cells is the same for each sheet:

VBA Code: 
Sub CopyValues(sourceCell As Range)
    Dim sourceSheet As Worksheet
    Set sourceSheet = sourceCell.Worksheet
    
    Dim cellAddress2 As String
    cellAddress2 = sourceCell.Address(0, 0)
    Dim rw As Long
    rw = sourceCell.Row
    
    Dim cellAddress1 As String
    cellAddress1 = Replace$(cellAddress2, rw, "5")
    Dim cellAddress3 As String
    cellAddress3 = "A" & rw
    Sheets("COVERSHEET").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Resize(, 3).Value = _
                        Array(sourceSheet.Range(cellAddress1).Value, sourceSheet.Range(cellAddress2).Value, sourceSheet.Range(cellAddress3).Value)
End Sub
Private Sub Ret_Click()
    Dim cell As Range
    For Each cell In Sheets("TS TIME CARD").Range("C10:R10,C12:R12").Cells
        If Not IsEmpty(cell) Then CopyValues cell
    Next cell
End Sub
 
Upvote 0
This seems to work on the one sheet as well but doesn't proceed on to run on the other sheets. Is it possible to add the other sheets names to this piece of code?
VBA Code: 
Private Sub Ret_Click()
    Dim cell As Range
    For Each cell In Sheets("TS TIME CARD").Range("C10:R36").Cells
        If Not IsEmpty(cell) Then CopyValues cell
    Next cell
End Sub

I've been trying to add the other sheets in there but am getting errors and know I'm not doing it right
 
Upvote 0
You'd just repeat this part:

Code: 
    For Each cell In Sheets("TS TIME CARD").Range("C10:R36").Cells
        If Not IsEmpty(cell) Then CopyValues cell
    Next cell

changing the sheet name and the ranges as required.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
703
Joe4
Joe4
H
  • Question
Macro to Limit Selection in Directory
Replies
4
Views
240
howard
H
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
175
bh24524
B
N
  • Solved
VBA - Increment range and loop until blank Cell
Replies
3
Views
116
dreid1011
dreid1011
F
  • Solved
Simplifying a code
Replies
6
Views
251
MARK858
MARK858

Forum statistics

Threads
1,214,632
Messages
6,120,655
Members
448,975
Latest member
sweeberry

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