How to speedup VBA

chunu

Board Regular
Joined
Jul 5, 2012
Messages
99
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
 
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

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
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


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

Forum statistics

Threads
1,213,554
Messages
6,114,280
Members
448,562
Latest member
Flashbond

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