How to speedup VBA

chunu

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

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
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:

Some videos you may like

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

chunu

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

[URL="https://ibb.co/BtZWBM4"][IMG]https://i.ibb.co/rm68Hrb/ARRC.jpg[/URL][/IMG]
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
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
 

chunu

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

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

put a test is to check if the data is blank
 

chunu

Board Regular
Joined
Jul 5, 2012
Messages
74
Hi,

It is coping/repeating (inv,date,name,mobile) with blank data
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

put this line in after the loop start:
Code:
 For j = 8 To 14 Step 1
    if inarr(j,1)="" then exit for
 

chunu

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

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,493
Office Version
  1. 2010
Platform
  1. Windows
I am pleased to hear that it is now much faster.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,486
Messages
5,548,347
Members
410,828
Latest member
A9Bosv3
Top