How to speedup VBA

C

chunu

Board Regular
Joined
Jul 5, 2012
Messages
109
Office Version
  1. 2013
Platform
  1. Windows
  2. Mobile
Hi,
I used to transfer invoice data to another workbook [data], sheet "sales" and sheet"csales also add new workbook invoice sheet with below code, it took 3 second to complete.
is there is way to speed up this process.

Code: 
Sub SavingSalesData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim wb As Workbook  '''!
Dim CurrentWB As Workbook  '''!
Dim WBLoc As String  '''!
Dim rng As Range
Dim i As Long
Dim a As Long
Dim b As Long
Dim rng_dest As Range




WBLoc = "g:\data.xlsm"  '''! Location of the workbook
Set CurrentWB = Excel.ThisWorkbook  '''!
Set wb = Workbooks.Open(WBLoc)   '''! Opens the workbook
wb.Sheets("sales").Unprotect Password:="123"
wb.Sheets("csales").Unprotect Password:="123"


i = 1
Set rng_dest = wb.Sheets("sales").Range("D:i") '''! Change Sheets() to whichever sheet you want to use


' Find first empty row in columns D:F on sheet Sales Book
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
   i = i + 1
Loop


'Copy range A23:D27 on sheet Invoice to Variant array
Set rng = CurrentWB.Sheets("Invoice").Range("A8:e24") '''!


' Copy rows containing values to sheet Sales Book
For a = 1 To rng.Rows.Count
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
  rng_dest.Rows(i).Value = rng.Rows(a).Value
  
  
  
  With wb.Sheets(1)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = CurrentWB.Sheets("Invoice").Range("e3").Value2 '''!
     'Copy Date
     .Range("b" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f4").Value2 '''!
     'Copy Company name
     .Range("C" & i).Value2 = CurrentWB.Sheets("Invoice").Range("d6").Value2 '''!
     'tel
     .Range("d" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f6").Value2 '
     'dis
     .Range("j" & i).Value2 = CurrentWB.Sheets("Invoice").Range("h26").Value2 '
     'id
     .Range("l" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f5").Value2 '
     
     'amount
     .Range("i" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f25").Value2 '
    
             
             
           i = 1
Set rng_dest = wb.Sheets("csales").Range("D:i") '''! Change Sheets() to whichever sheet you want to use


' Find first empty row in columns D:F on sheet Sales Book
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
   i = i + 1
Loop


'Copy range A23:D27 on sheet Invoice to Variant array
Set rng = CurrentWB.Sheets("Invoice").Range("A8:e24") '''!




      With wb.Sheets(2)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = CurrentWB.Sheets("Invoice").Range("e3").Value2 '''!
     'Copy Date
     .Range("b" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f4").Value2 '''!
     'name
     .Range("C" & i).Value2 = CurrentWB.Sheets("Invoice").Range("d6").Value2 '''!
     'tel
     .Range("d" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f6").Value2 '
     'id
     .Range("e" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f5").Value2 '
     'amount
     .Range("f" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f25").Value2 '
     'Discount
     .Range("g" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f26").Value2 '
     'paid
     .Range("h" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f27").Value2 '
     'balance
     .Range("i" & i).Value2 = CurrentWB.Sheets("Invoice").Range("f28").Value2 '
     
     '.Range("f" & i).Value = CurrentWB.Sheets("Invoice").Range("f5").Value '
       
         
 
    End With  '''!
End With  '''!
    '''!
  i = i + 1
End If


Next a
wb.Sheets("sales").Protect Password:="123"
wb.Sheets("csales").Protect Password:="123"
ThisWorkbook.Activate
wb.Close savechanges:=True  '''! This wil close the Workbook and save changes


Set wb = Nothing  '''! Cleaning memory
Set CurrentWB = Nothing  '''! Cleaning memory
   


Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub

Code: 
Sub saveInvWithNewName()Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim NewFN As Variant
SavingSalesData
Dim smallrng As Range
'copy invoice to a new workbook
If Dir("g:\aaa", vbDirectory) = "" Then
    MkDir Path:="g:\aaa"
End If
If Len(Dir("g:\aaa\" & MonthName(Month(Date), False), vbDirectory)) = 0 Then
    MkDir "g:\aaa\" & MonthName(Month(Date), False)


End If










Set newbook = Workbooks.Add
  Workbooks("invoice.xlsm").Worksheets("invoice").Range("b1:f28").Copy
 
    newbook.Worksheets("Sheet1").Range("b1").PasteSpecial Paste:=xlPasteColumnWidths
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False










    For Each smallrng In Range("f8:f28,f4").Areas


        


        With smallrng
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    Next smallrng




   
 NewFN = "g:\aaa\" & MonthName(Month(Date), False) & "\" & "inv" & Range("e3") & "-" & Format(Date, "mmm.yyyy") & ".xlsx"
     
  ActiveSheet.SaveAs Filename:=NewFN
  
   
   ActiveWorkbook.Close
    
     
 
nextInvoice


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic


End Sub

Thanks
 
Sort by date Sort by votes
it is not entirely clear which which cells your variables are sitting in and I don't know which sheets are the source and destination, so I am sure this is not correct but it should show you how to do it:
Code: 
Sub test()
Dim outarr(1 To 7, 1 To 9) As Variant


With Worksheets("sheet1")
 ' this is assumed to be the sheet with the red marks on it
 ' load all the data inot a variant array
 inarr = .Range("A1:E24")
End With
With Worksheets("sheet2")
 ' this is assumed to be othe sheet
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    ' invoice No.
        outarr(1, 1) = inarr(3, 5) 'assumed to be E3
    ' date
        outarr(1, 2) = inarr(4, 5) ' Assumed to E4
    ' Name
        outarr(1, 3) = inarr(6, 3) ' Assumed to C6
     ' Mobile
        outarr(1, 3) = inarr(6, 5) ' Assumed to E6
     For j = 8 To 14 Step 1
       For k = 1 To 5
        outarr(j - 7, k + 4) = inarr(j, k)
       Next k
     Next j
   .Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 7, 9)) = outarr
 End With
    
    


End Sub
 
Last edited:
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
offthelip said:
it is not entirely clear which which cells your variables are sitting in and I don't know which sheets are the source and destination, so I am sure this is not correct but it should show you how to do it:
Code: 
Sub test()
Dim outarr(1 To 7, 1 To 9) As Variant


With Worksheets("sheet1")
 ' this is assumed to be the sheet with the red marks on it
 ' load all the data inot a variant array
 inarr = .Range("A1:E24")
End With
With Worksheets("sheet2")
 ' this is assumed to be othe sheet
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    ' invoice No.
        outarr(1, 1) = inarr(3, 5) 'assumed to be E3
    ' date
        outarr(1, 2) = inarr(4, 5) ' Assumed to E4
    ' Name
        outarr(1, 3) = inarr(6, 3) ' Assumed to C6
     ' Mobile
        outarr(1, 3) = inarr(6, 5) ' Assumed to E6
     For j = 8 To 14 Step 1
       For k = 1 To 5
        outarr(j - 7, k + 4) = inarr(j, k)
       Next k
     Next j
   .Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 7, 9)) = outarr
 End With
    
    


End Sub
Click to expand...


Hi,
Thank you so much for your help, almost done.
If only one row in source sheet then its ok but if there is more then one then i want to repeat(inv, date,name, mobile)in sheet2
please see i have attached the image as i want.


Thanks once again.

ARRC.jpg
[/URL][/IMG]
 
Upvote 0
try this:
Code: 
Sub test()
Dim outarr(1 To 7, 1 To 9) As Variant




With Worksheets("sheet1")
 ' this is assumed to be the sheet with the red marks on it
 ' load all the data inot a variant array
 inarr = .Range("A1:E24")
End With
With Worksheets("sheet2")
 ' this is assumed to be othe sheet
  lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
     For j = 8 To 14 Step 1
    
    ' invoice No.
        outarr(j - 7, 1) = inarr(3, 5) 'assumed to be E3
    ' date
        outarr(j - 7, 2) = inarr(4, 5) ' Assumed to E4
    ' Name
        outarr(j - 7, 3) = inarr(6, 3)  ' Assumed to C6
     ' Mobile
        outarr(j - 7, 3) = inarr(6, 5) ' Assumed to E6
       For k = 1 To 5
        outarr(j - 7, k + 4) = inarr(j, k)
       Next k
     Next j
   .Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 7, 9)) = outarr
 End With
End Sub
 
Upvote 0
Hi,
i tried this repeats 7 times, i want it should repeat only with data, if there is one row in source sheet repeat one time if two rows repeat two time.
Thanks
 
Upvote 0
Hi,

It is coping/repeating (inv,date,name,mobile) with blank data
 
Upvote 0
put this line in after the loop start:
Code: 
 For j = 8 To 14 Step 1
    if inarr(j,1)="" then exit for
 
Upvote 0
***wonderful***
I am very thank full and appreciate the way you help me.
macro execution speed has been reduce from 3 second to 1 second.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Simplify my working code please
Replies
7
Views
186
ipbr21054
I
I
  • Question Question
Value not shown in ComboBox1 when code run
Replies
1
Views
59
ipbr21054
I
I
  • Solved
Subscript out of range when copying values to another sheet
Replies
9
Views
206
ipbr21054
I
brent3162
  • Solved
VBA help with increasing row before macro runs again.
Replies
3
Views
378
jolivanes
jolivanes
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
189
sijpie
sijpie

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

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