How to speedup VBA

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
954
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:

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

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
954
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
954
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
954
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.
 

Forum statistics

Threads
1,078,344
Messages
5,339,663
Members
399,318
Latest member
kryten68

Some videos you may like

This Week's Hot Topics

Top