How to speedup VBA

[chunu]

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.

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

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]

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:

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

 

[chunu]

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:

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][/IMG]

 

[offthelip]

try this:

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]

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]

put a test is to check if the data is blank

 

[chunu]

Hi,

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

 

[offthelip]

put this line in after the loop start:

 For j = 8 To 14 Step 1
    if inarr(j,1)="" then exit for

 

[chunu]

***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]

I am pleased to hear that it is now much faster.