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
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
Geez, opening a workbook, cycling through aheap of data AND saving to a new workbook in 3 seconds isn't really that bad !!
Have you tried having the workbook open first ??
 
Upvote 0
Thanks for your time , i do not want to open workbook first.
if i remove password line (wb.Sheets("sales").Unprotect Password:="123"wb.Sheets("csales").Unprotect Password:="123") then execution time reduce to 1.80 second but i want password protection too.

Michael M said:
Geez, opening a workbook, cycling through aheap of data AND saving to a new workbook in 3 seconds isn't really that bad !!
Have you tried having the workbook open first ??
Click to expand...
 
Last edited:
Upvote 0
Well, my first comment still applies....
Geez, opening a workbook, cycling through aheap of data AND saving to a new workbook in 3 seconds isn't really that bad !!
Click to expand...
 
Upvote 0
You can definitely speed up your macro a lot:
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
You are making multiple accesses to the worksheet on every loop and you have got a double loop, the only reason this only takes 3 seconds is because you don't have alot of rows. if you had 5000 it would take many minutes.
you have this statemet:
Code: 
'Copy range A23:D27 on sheet Invoice to Variant array
Set rng = CurrentWB.Sheets("Invoice").Range("A8:e24") '''!
this DOES NOT copy the data to a variant array it sets a range variable to a range.
To copy the data to a variant array you need a statement like
Code: 
Dim inarr as variant
inarr = CurrentWB.Sheets("Invoice").Range("A1:e24")
Note I have changed the range to pick the data up from A1 because it makes working out the indices easier because they are the same as the column rows

then to reference tha value in E3, you use numerical indexing
so:
Code: 
.Range("a" & i).Value2 = CurrentWB.Sheets("Invoice").Range("e3").Value2 '''!
becomes
Code: 
.Range("a" & i).Value2 = inarr(3,5)
you can do exactly the same for the output array so instead of copying cell to cell you copy variant array to varaint array and then write the output array back to the workhseet at the end.
 
Last edited:
Upvote 0
Hi offthelip,
Thank for you help, in fact i do not know any thing about vba, i just get the codes from different sources and use for my needs.
i have change the code as you suggest.
Below lines are giving error "object variable or with block variable not set"

Code: 
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
  rng_dest.Rows(i).Value = rng.Rows(a).Value

if i remove these line then its copy only .Range("a" & i).Value2 = inarr(3, 5) ,for other cells says "subscript out of range"
Code: 
.Range("a" & i).Value2 = inarr(3, 5) '''!
     'Copy Date
     .Range("a" & i).Value2 = inarr(4, 6) '''!
     'Copy Company name
     .Range("a" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("a" & i).Value2 = inarr(6, 6) '
     'dis
     .Range("a" & i).Value2 = inarr(26, 8) '
     'id
     .Range("a" & i).Value2 = inarr(5, 6) '
     
     'amount
     .Range("a" & i).Value2 = inarr(25, 6)

sorry for inconvenience
 
Upvote 0
offthelip said:
Can you post all of your code, please
Click to expand...
Here the code
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
Dim inarr As Variant


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


'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
inarr = CurrentWB.Sheets("Invoice").Range("A1:e24") '''!


' Copy rows containing values to sheet Sales Book
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 = inarr(3, 5) '''!
     'Copy Date
     .Range("b" & i).Value2 = inarr(4, 6) '''!
     'Copy Company name
     .Range("c" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("d" & i).Value2 = inarr(6, 6) '
     'dis
     .Range("j" & i).Value2 = inarr(26, 8) '
     'id
     .Range("l" & i).Value2 = inarr(5, 6) '
     
     'amount
     .Range("i" & i).Value2 = inarr(25, 6)
    
             
             
           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
 
Upvote 0
I have modified your code to show you how to do it partly with variant arrays. I don't have time to completely rewrite. this is still writing to individual cells on every loops but it is now not reading from individual cells on every loop, so it is nearly half way there.
Aslo there no need to detect the next free line on every loop, that can be done once.
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
Dim inarr As Variant




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




'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
inarr = CurrentWB.Sheets("Invoice").Range("A1:F28") '''! changed this to F28 because you need it lower down


' Copy rows containing values to sheet Sales Book
For a = 1 To UBound(inarr, 1)
' Copy rows containing values to sheet Sales Book
  'check if any values on this row
  valuefnd = False
  For kk = 1 To UBound(inarr, 2)
   If inarr(a, kk) <> 0 Then
    valuefnd = True
    Exit For
   End If
  Next kk
'If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
'  rng_dest.Rows(i).Value = rng.Rows(a).Value
  
If valuefnd Then
  
  With wb.Sheets(1)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = inarr(3, 5) '''!
     'Copy Date
     .Range("b" & i).Value2 = inarr(4, 6) '''!
     'Copy Company name
     .Range("c" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("d" & i).Value2 = inarr(6, 6) '
     'dis
     .Range("j" & i).Value2 = inarr(26, 8) '
     'id
     .Range("l" & i).Value2 = inarr(5, 6) '
     
     'amount
     .Range("i" & i).Value2 = inarr(25, 6)
    
  End If
             
           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") '''! we don't need this inarr is already loaded








      With wb.Sheets(2)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = inarr(3, 5) '''!
     'Copy Date
     .Range("b" & i).Value2 = inarr(4, 6) '''!
     'name
     .Range("C" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("d" & i).Value2 = inarr(6, 6) '
     'id
     .Range("e" & i).Value2 = inarr(5, 6) '
     'amount
     .Range("f" & i).Value2 = inarr(25, 6) '
     'Discount
     .Range("g" & i).Value2 = inarr(26, 6) '
     'paid
     .Range("h" & i).Value2 = inarr(27, 6) '
     'balance
     .Range("i" & i).Value2 = inarr(28, 6) '
     
     '.Range("f" & i).Value = CurrentWB.Sheets("Invoice").Range("f5").Value '
       
         
 
    End With  '''!
End With  '''!
    '''!
  i = i + 1
'End If




Next a ' we still need the a loop
'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
 
Upvote 0
offthelip said:
I have modified your code to show you how to do it partly with variant arrays. I don't have time to completely rewrite. this is still writing to individual cells on every loops but it is now not reading from individual cells on every loop, so it is nearly half way there.
Aslo there no need to detect the next free line on every loop, that can be done once.
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
Dim inarr As Variant




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




'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
inarr = CurrentWB.Sheets("Invoice").Range("A1:F28") '''! changed this to F28 because you need it lower down


' Copy rows containing values to sheet Sales Book
For a = 1 To UBound(inarr, 1)
' Copy rows containing values to sheet Sales Book
  'check if any values on this row
  valuefnd = False
  For kk = 1 To UBound(inarr, 2)
   If inarr(a, kk) <> 0 Then
    valuefnd = True
    Exit For
   End If
  Next kk
'If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
'  rng_dest.Rows(i).Value = rng.Rows(a).Value
  
If valuefnd Then
  
  With wb.Sheets(1)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = inarr(3, 5) '''!
     'Copy Date
     .Range("b" & i).Value2 = inarr(4, 6) '''!
     'Copy Company name
     .Range("c" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("d" & i).Value2 = inarr(6, 6) '
     'dis
     .Range("j" & i).Value2 = inarr(26, 8) '
     'id
     .Range("l" & i).Value2 = inarr(5, 6) '
     
     'amount
     .Range("i" & i).Value2 = inarr(25, 6)
    
  End If
             
           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") '''! we don't need this inarr is already loaded








      With wb.Sheets(2)  '''! Change Sheets() to whichever sheet you want to use
     'Copy Invoice number
     .Range("a" & i).Value2 = inarr(3, 5) '''!
     'Copy Date
     .Range("b" & i).Value2 = inarr(4, 6) '''!
     'name
     .Range("C" & i).Value2 = inarr(6, 4) '''!
     'tel
     .Range("d" & i).Value2 = inarr(6, 6) '
     'id
     .Range("e" & i).Value2 = inarr(5, 6) '
     'amount
     .Range("f" & i).Value2 = inarr(25, 6) '
     'Discount
     .Range("g" & i).Value2 = inarr(26, 6) '
     'paid
     .Range("h" & i).Value2 = inarr(27, 6) '
     'balance
     .Range("i" & i).Value2 = inarr(28, 6) '
     
     '.Range("f" & i).Value = CurrentWB.Sheets("Invoice").Range("f5").Value '
       
         
 
    End With  '''!
End With  '''!
    '''!
  i = i + 1
'End If




Next a ' we still need the a loop
'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
Click to expand...

Hi,


for sheet "csales" i mange with below code but for sheet "sales" i need your help.
i have attached a image to show how excactlly i want to do.
TLgTqdW


Thanks
URL]


TLgTqdW

Code: 
Dim myRng As Range
Dim rngc As Range
Dim i As Long
Dim myArr() As Variant
Set myRng = ThisWorkbook.Sheets("invoice").Range("e3, f4, d6, f6, f5, f25,f26,f27,f28")


For Each rngc In myRng
    ReDim Preserve myArr(myRng.Cells.Count - 1)
    myArr(i) = rngc
    i = i + 1
Next


wb.Sheets("csales").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(columnsize:=myRng.Cells.Count) = myArr

TLgTqdW
 
Last edited:
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
58
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,818
Messages
6,181,152
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