More efficient code/method?

kcmuppet

Active Member
Joined
Nov 2, 2005
Messages
435
Office Version
  1. 365
  2. 2010
I'm not very good with VBA code, (I tend to modify/customise based on recording macros rather than attempt build from scratch) so please bear with me...!

Can anybody please help me make the code below more efficient. It basically scrapes some fields off an invoice sheet (sheet17) and transfers them onto a blank row on another sheet ('Income!'). It works OK, but it takes over a minute each time to run on my pc, and I sort of wish it was more flexible (to allow insertions/deletions

Code:
Sub TestTransferToIncome()
Dim rngInvNumber As Range
    Set rngInvNumber = Range("Income!A2:A1000")
    For i = 1 To 1000
        With rngInvNumber
            If .Cells(i, 1) = "" Then
            Rem Invoice Number...
                .Cells(i, 1).Value = Sheet17.Range("L12").Value
            Rem Customer Name from drop-down...
                .Cells(i, 3).Value = Sheet17.Range("B11").Value
            Rem Sub Total...
                .Cells(i, 4).Value = Sheet17.Range("L41").Value
            Rem Total VAT...
                .Cells(i, 5).Value = Sheet17.Range("L43").Value
            Rem Total Due...
                .Cells(i, 6).Value = Sheet17.Range("L45").Value
            Rem Invoice Date...
                .Cells(i, 7).Value = Sheet17.Range("B13").Value
            Rem Invoice Item 01 fee category
                .Cells(i, 25).Value = Sheet17.Range("B21").Value
            Rem Invoice Item 02 fee category
                .Cells(i, 26).Value = Sheet17.Range("B22").Value
            Rem Invoice Item 03 fee category
                .Cells(i, 27).Value = Sheet17.Range("B23").Value
            Rem Invoice Item 04 fee category
                .Cells(i, 28).Value = Sheet17.Range("B24").Value
            Rem Invoice Item 05 fee category
                .Cells(i, 29).Value = Sheet17.Range("B25").Value
            Rem Invoice Item 06 fee category
                .Cells(i, 30).Value = Sheet17.Range("B26").Value
            Rem Invoice Item 07 fee category
                .Cells(i, 31).Value = Sheet17.Range("B27").Value
            Rem Invoice Item 08 fee category
                .Cells(i, 32).Value = Sheet17.Range("B28").Value
            Rem Invoice Item 09 fee category
                .Cells(i, 33).Value = Sheet17.Range("B29").Value
            Rem Invoice Item 10 fee category
                .Cells(i, 34).Value = Sheet17.Range("B30").Value
            Rem Invoice Item 11 fee category
                .Cells(i, 35).Value = Sheet17.Range("B31").Value
            Rem Invoice Item 12 fee category
                .Cells(i, 36).Value = Sheet17.Range("B32").Value
            Rem Invoice Item 13 fee category
                .Cells(i, 37).Value = Sheet17.Range("B33").Value
            Rem Invoice Item 14 fee category
                .Cells(i, 38).Value = Sheet17.Range("B34").Value
            Rem Invoice Item 15 fee category
                .Cells(i, 39).Value = Sheet17.Range("B35").Value
            Rem Invoice Item 16 fee category
                .Cells(i, 40).Value = Sheet17.Range("B36").Value
            Rem Invoice Item 17 fee category
                .Cells(i, 41).Value = Sheet17.Range("B37").Value
            Rem Invoice Item 18 fee category
                .Cells(i, 42).Value = Sheet17.Range("B38").Value
            Rem Invoice Item 19 fee category
                .Cells(i, 43).Value = Sheet17.Range("B39").Value
            Rem Invoice Item 01 description
                .Cells(i, 44).Value = Sheet17.Range("F21,G21,H21,I21,J21,K21").Value
            Rem Invoice Item 02 description
                .Cells(i, 45).Value = Sheet17.Range("F22,G22,H22,I22,J22,K22").Value
            Rem Invoice Item 03 description
                .Cells(i, 46).Value = Sheet17.Range("F23,G23,H23,I23,J23,K23").Value
            Rem Invoice Item 04 description
                .Cells(i, 47).Value = Sheet17.Range("F24,G24,H24,I24,J24,K24").Value
            Rem Invoice Item 05 description
                .Cells(i, 48).Value = Sheet17.Range("F25,G25,H25,I25,J25,K25").Value
            Rem Invoice Item 06 description
                .Cells(i, 49).Value = Sheet17.Range("F26,G26,H26,I26,J26,K26").Value
            Rem Invoice Item 07 description
                .Cells(i, 50).Value = Sheet17.Range("F27,G27,H27,I27,J27,K27").Value
            Rem Invoice Item 08 description
                .Cells(i, 51).Value = Sheet17.Range("F28,G28,H28,I28,J28,K28").Value
            Rem Invoice Item 09 description
                .Cells(i, 52).Value = Sheet17.Range("F29,G29,H29,I29,J29,K29").Value
            Rem Invoice Item 10 description
                .Cells(i, 53).Value = Sheet17.Range("F30,G30,H30,I30,J30,K30").Value
            Rem Invoice Item 11 description
                .Cells(i, 54).Value = Sheet17.Range("F31,G31,H31,I31,J31,K31").Value
            Rem Invoice Item 12 description
                .Cells(i, 55).Value = Sheet17.Range("F32,G32,H32,I32,J32,K32").Value
            Rem Invoice Item 13 description
                .Cells(i, 56).Value = Sheet17.Range("F33,G33,H33,I33,J33,K33").Value
            Rem Invoice Item 14 description
                .Cells(i, 57).Value = Sheet17.Range("F34,G34,H34,I34,J34,K34").Value
            Rem Invoice Item 15 description
                .Cells(i, 58).Value = Sheet17.Range("F35,G35,H35,I35,J35,K35").Value
            Rem Invoice Item 16 description
                .Cells(i, 59).Value = Sheet17.Range("F36,G36,H36,I36,J36,K36").Value
            Rem Invoice Item 17 description
                .Cells(i, 60).Value = Sheet17.Range("F37,G37,H37,I37,J37,K37").Value
            Rem Invoice Item 18 description
                .Cells(i, 61).Value = Sheet17.Range("F38,G38,H38,I38,J38,K38").Value
            Rem Invoice Item 19 description
                .Cells(i, 62).Value = Sheet17.Range("F39,G39,H39,I39,J39,K39").Value
            Rem Invoice Item 01 amount
                .Cells(i, 63).Value = Sheet17.Range("L21").Value
            Rem Invoice Item 02 amount
                .Cells(i, 64).Value = Sheet17.Range("L22").Value
            Rem Invoice Item 03 amount
                .Cells(i, 65).Value = Sheet17.Range("L23").Value
            Rem Invoice Item 04 amount
                .Cells(i, 66).Value = Sheet17.Range("L24").Value
            Rem Invoice Item 05 amount
                .Cells(i, 67).Value = Sheet17.Range("L25").Value
            Rem Invoice Item 06 amount
                .Cells(i, 68).Value = Sheet17.Range("L26").Value
            Rem Invoice Item 07 amount
                .Cells(i, 69).Value = Sheet17.Range("L27").Value
            Rem Invoice Item 08 amount
                .Cells(i, 70).Value = Sheet17.Range("L28").Value
            Rem Invoice Item 09 amount
                .Cells(i, 71).Value = Sheet17.Range("L29").Value
            Rem Invoice Item 10 amount
                .Cells(i, 72).Value = Sheet17.Range("L30").Value
            Rem Invoice Item 11 amount
                .Cells(i, 73).Value = Sheet17.Range("L31").Value
            Rem Invoice Item 12 amount
                .Cells(i, 74).Value = Sheet17.Range("L32").Value
            Rem Invoice Item 13 amount
                .Cells(i, 75).Value = Sheet17.Range("L33").Value
            Rem Invoice Item 14 amount
                .Cells(i, 76).Value = Sheet17.Range("L34").Value
            Rem Invoice Item 15 amount
                .Cells(i, 77).Value = Sheet17.Range("L35").Value
            Rem Invoice Item 16 amount
                .Cells(i, 78).Value = Sheet17.Range("L36").Value
            Rem Invoice Item 17 amount
                .Cells(i, 79).Value = Sheet17.Range("L37").Value
            Rem Invoice Item 18 amount
                .Cells(i, 80).Value = Sheet17.Range("L38").Value
            Rem Invoice Item 19 amount
                .Cells(i, 81).Value = Sheet17.Range("L39").Value
                Exit For
            End If
        End With
    Next i
End Sub

Thanks very much
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
On the Income sheet, column A starting at row 2, you want to first find the last used cell and then add the current record to the next row down, right?
 
Upvote 0
Why are you doing it 1000 times? Where the range is contiguous you can Copy/Paste Special Values. For example:

Code:
           Rem Invoice Item 01 fee category 
                .Cells(i, 25).Value = Sheet17.Range("B21").Value 
            Rem Invoice Item 02 fee category 
                .Cells(i, 26).Value = Sheet17.Range("B22").Value 
            Rem Invoice Item 03 fee category 
                .Cells(i, 27).Value = Sheet17.Range("B23").Value 
            Rem Invoice Item 04 fee category 
                .Cells(i, 28).Value = Sheet17.Range("B24").Value 
            Rem Invoice Item 05 fee category 
                .Cells(i, 29).Value = Sheet17.Range("B25").Value 
            Rem Invoice Item 06 fee category 
                .Cells(i, 30).Value = Sheet17.Range("B26").Value 
            Rem Invoice Item 07 fee category 
                .Cells(i, 31).Value = Sheet17.Range("B27").Value 
            Rem Invoice Item 08 fee category 
                .Cells(i, 32).Value = Sheet17.Range("B28").Value 
            Rem Invoice Item 09 fee category 
                .Cells(i, 33).Value = Sheet17.Range("B29").Value 
            Rem Invoice Item 10 fee category 
                .Cells(i, 34).Value = Sheet17.Range("B30").Value 
            Rem Invoice Item 11 fee category 
                .Cells(i, 35).Value = Sheet17.Range("B31").Value 
            Rem Invoice Item 12 fee category 
                .Cells(i, 36).Value = Sheet17.Range("B32").Value 
            Rem Invoice Item 13 fee category 
                .Cells(i, 37).Value = Sheet17.Range("B33").Value 
            Rem Invoice Item 14 fee category 
                .Cells(i, 38).Value = Sheet17.Range("B34").Value 
            Rem Invoice Item 15 fee category 
                .Cells(i, 39).Value = Sheet17.Range("B35").Value 
            Rem Invoice Item 16 fee category 
                .Cells(i, 40).Value = Sheet17.Range("B36").Value 
            Rem Invoice Item 17 fee category 
                .Cells(i, 41).Value = Sheet17.Range("B37").Value 
            Rem Invoice Item 18 fee category 
                .Cells(i, 42).Value = Sheet17.Range("B38").Value 
            Rem Invoice Item 19 fee category 
                .Cells(i, 43).Value = Sheet17.Range("B39").Value

could be rewritten as:

Code:
Sheet17.Range("B21:B39").Copy
.Cells(i, 25).PasteSpecial Paste:=xlValues
 
Upvote 0
<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> TestTransferToIncome()
Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> LastRow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
<SPAN style="color:#00007F">With</SPAN> Worksheets("Income")
    LastRow = .Cells(Rows.Count, "a").End(xlUp).Row + 1
    .Cells(LastRow, 1).Value = Sheet17.Range("L12").Value
    .Cells(LastRow, 3).Value = Sheet17.Range("B11").Value
    .Cells(LastRow, 4).Value = Sheet17.Range("L41").Value
    .Cells(LastRow, 5).Value = Sheet17.Range("L43").Value
    .Cells(LastRow, 6).Value = Sheet17.Range("L45").Value
    .Cells(LastRow, 7).Value = Sheet17.Range("B13").Value
    .Range(.Cells(LastRow, 25), .Cells(LastRow, 43)).Value = Sheet17.Range("B21:B39").Value
    <SPAN style="color:#007F00">' Are the below supposed to be the sums of the referenced cells?</SPAN>
    <SPAN style="color:#00007F">For</SPAN> j = 44 <SPAN style="color:#00007F">To</SPAN> 62
        .Cells(LastRow, j) = Application.WorksheetFunction.Sum(Sheet17.Range("F" & j - 23 & ":K" & j - 23))
    <SPAN style="color:#00007F">Next</SPAN> j
    .Range(.Cells(LastRow, 63), .Cells(LastRow, 81)).Value = Sheet17.Range("L21:L39").Value
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN>
</FONT>
Untested.
 
Upvote 0
just_jon said:
On the Income sheet, column A starting at row 2, you want to first find the last used cell and then add the current record to the next row down, right?

Yes, that's right



Andrew Poulsom said:
Why are you doing it 1000 times?
Er...Good question. I was sort of assuming I had to set up enough space in the destination, so that I wouldn't run out! Is there a better way of doing it?

Andrew Poulsom said:
...could be rewritten as:
Code:
Sheet17.Range("B21:B39").Copy
.Cells(i, 25).PasteSpecial Paste:=xlValues
Thanks, I'm not sure how to get it to post horizontally - is there a 'transpose' argument?
 
Upvote 0
just_jon said:
' Are the below supposed to be the sums of the referenced cells?
No, it's because the source is a range of merged cells, but I wanted the contents in just one column.

Just trying your suggestion...thanks
 
Upvote 0
Andrew Poulsom said:
et

Andrew Poulsom said:
...could be rewritten as:
Code:
Sheet17.Range("B21:B39").Copy
.Cells(i, 25).PasteSpecial Paste:=xlValues
Thanks, I'm not sure how to get it to post horizontally - is there a 'transpose' argument?[/quote:38ddd888d9]

Ah yes:

.Cells(i, 25).PasteSpecial Paste:=xlValues, Transpose:=True
 
Upvote 0
Thank you both very much indeed - it now takes only 12 seconds!

just_jon said:
See my revised post above.

Do you have time to explain how this works:

Code:
    For j = 44 To 62
        .Cells(LastRow, j) = Application.WorksheetFunction.Sum(Sheet17.Range("F" & j - 23 & ":K" & j - 23))
    Next j
 
Upvote 0
kcmuppet said:
Thank you both very much indeed - it now takes only 12 seconds!

just_jon said:
See my revised post above.

Do you have time to explain how this works:

Code:
    For j = 44 To 62
        .Cells(LastRow, j) = Application.WorksheetFunction.Sum(Sheet17.Range("F" & j - 23 & ":K" & j - 23))
    Next j

Well, as you are not summing, not well! :LOL:

When the variable j has a value of 44, as it will the 1st time through the loop, the Sheet17 sit translates as:

Range(F[44-23]:K[44-23])
= RANGE(F21:K21)

So, the cell at column j (44th column) would be ths sum of sheet17's row 21, columns F thru K.
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,245
Members
448,555
Latest member
RobertJones1986

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