More efficient code/method?

K

kcmuppet

Active Member
Joined
Nov 2, 2005
Messages
437
Office Version
  1. 365
Platform
  1. Windows
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
 
Sort by date Sort by votes

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
just_jon said:
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.
Click to expand...

Hello Jon, the trouble is, I get just zeros in the destination cells. You might remember, the source is a range of merged cells in each row, but I wanted the destination contents in just one cell per row.
 
Upvote 0
Sorry, perhaps I didn't make clear the merged cells at the origin contain text, not numbers
 
Upvote 0
I guess I'm having trouble seeing your layout - does this come close?

<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 = Sheet1.Range("L12").Value
    .Cells(LastRow, 3).Value = Sheet1.Range("B11").Value
    .Cells(LastRow, 4).Value = Sheet1.Range("L41").Value
    .Cells(LastRow, 5).Value = Sheet1.Range("L43").Value
    .Cells(LastRow, 6).Value = Sheet1.Range("L45").Value
    .Cells(LastRow, 7).Value = Sheet1.Range("B13").Value
    .Range(.Cells(LastRow, 25), .Cells(LastRow, 43)).Value = Sheet1.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) = Sheet1.Range("F" & j - 23)
    <SPAN style="color:#00007F">Next</SPAN> j
    .Range(.Cells(LastRow, 63), .Cells(LastRow, 81)).Value = Sheet1.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>
 
Upvote 0
Hi Jon, Thanks for coming back to me, and bearing with it. Hopefully I can clarify...

' Are the below supposed to be the sums of the referenced cells?
[/code]
The answer to this is no, they're supposed to be the concatenated text of 5 cells (F:K), for each row (21:39)

Also, this...
Code: 
  .Range(.Cells(LastRow, 63), .Cells(LastRow, 81)).Value = Sheet1.Range("L21:L39").Value
...seems to populate all the destination cells with only the first origin cell, instead of moving each value (these are numbers).

Thanks again for looking at it.
 
Upvote 0
kcmuppet said:
This bit works great:
Code: 
    .Range(.Cells(LastRow, 25), .Cells(LastRow, 43)).Value = Sheet1.Range("B21:B39").Value
Click to expand...

Sorry, I should have checked more thoroughly, this bit also copies just the first item in the origin to all the cells in the desitination.
 
Upvote 0
Still having a hard time figuring out the layout; early morning, I guess.

Lets take a run at describing the situation, sans code, and describe hat should happen.
 
Upvote 0
Ok, here goes

I've got an invoice template that has space for 19 line items (rows 21:39), the details of which I'm transferring to another sheet on a single row.

Each line item on the invoice has 3 types of data.

The first type is the item category, in column B and is text.

The second type is the item amount (numbers), in column L.

The third type is the item description also text, but its merged across 5 columns, F:K. (I could, I suppose copy the contents to a single hidden cell on the same sheet, and transfer those to the 2nd sheet...)


Does that all make sense?

Anyway, the code I originally posted does actually work, but it takes forever, so I was hoping there would be a more efficient way.

Thanks again.
 
Upvote 0
Sorted!

Jon came up with this, which not only works perfectly, but runs in just 6-7 seconds - about ten times faster than my (clueless) first effort!


Code: 
Sub XferItems1()
Dim NextRowOnIncome As Long, SourceWkSt As Worksheet
Set SourceWkSt = Worksheets("Invoice Template") ' Just creating shorthand here
Application.ScreenUpdating = False ' Stop screen flicker
With Worksheets("Income")
    NextRowOnIncome = .Cells(Rows.Count, "A").End(xlUp).Row + 1 ' Find next blank row
    .Cells(NextRowOnIncome, "A") = SourceWkSt.[L13] ' Set Invoice Number
    .Cells(NextRowOnIncome, "B") = SourceWkSt.[B13] ' Set Invoice Date
    .Cells(NextRowOnIncome, "D") = SourceWkSt.[F11] ' Set Customer
    .Cells(NextRowOnIncome, "E") = SourceWkSt.[F17] ' Set Job
    .Cells(NextRowOnIncome, "F") = SourceWkSt.[L40] ' Set Sub Total
    SourceWkSt.[B21:B39].Copy ' Copy over the Item Categories
    .Cells(NextRowOnIncome, "Y").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    SourceWkSt.[F21:F39].Copy ' Copy over the Item Descriptions
    .Cells(NextRowOnIncome, "AR").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    SourceWkSt.[L21:L39].Copy ' Copy over the Item Prices
    .Cells(NextRowOnIncome, "BK").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Application.CutCopyMode = False ' Get rid of the marching ants
Application.ScreenUpdating = True ' Restore functionality
Set SourceWkSt = Nothing ' Release the object
End Sub


Thanks again Jon!
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
COUNTIFS FORMULA RETURNING ZERO
Replies
3
Views
123
Fluff
Fluff
I
  • Solved
OR - formula is giving #value error
Replies
6
Views
103
etaf
etaf
A
  • Solved
AVERAGEIFS with 4 criteria
2
Replies
16
Views
313
Fluff
Fluff
P
  • Solved
How to copy specific columns to other sheet in office 2021 without vba with some filter and format..
Replies
7
Views
100
Fluff
Fluff
S
  • Solved
Simple nesting issue
Replies
3
Views
281
Fluff
Fluff

Forum statistics

Threads
1,214,889
Messages
6,122,097
Members
449,065
Latest member
albertocarrillom

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