fast way to CopyPaste Non-Contiguous cells

chingilou · Apr 24, 2023

Hi ; I would like to just copy the values of several cells from sheet 1 to other sheets (6 data (not same for every sheets) x 9 sheets)
the method I use takes almost 9-8 seconds even though it is one step among others
in sheet 1 I put a table with the data to copy and the addresses in the target sheet

VBA Code:

Sub update3()
Dim X%, y%, NbLig%, Start%, Ends%, nb1%, nb2%, nb3%, lim%, nl%
Dim x1$, y1$, S$, w
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim rng As Range

nl = Application.CountIf(Feuil1.Range("B10:A196"), ">0")

'Grab Some Data and Store it in a "Range" variable
Set rng = Feuil1.Range("S10:S" & nl + 10)
'Transfer Values to same spot in another worksheet (Mimics PasteSpecial Values Only)
Feuil1.Range("B10").Resize(rng.Rows.Count, rng.Columns.Count).Cells.value = rng.Cells.value

Sheets("data").Range("O13") = nl
   
    Call snb2
    With Feuil1
        For y = 2 To 8
        S = Sheets("data").Cells(y, 1).value       'sheet
       
        For X = 2 To 10 Step 2 ' 8
        x1 = Sheets("data").Cells(y, X + 1).value   'x
        y1 = Sheets("data").Cells(y, X).value       'y
        'Sheets(s).Range(x1) = .Range(y1).value
        Sheets(S).Range(x1) = y1
        Next X
        ' date
        x1 = Sheets("data").Cells(y, 13).value   'x
        y1 = Format(Sheets("data").Cells(y, 12).value, "MM/dd/yyyy")    'y
        'Sheets(s).Range(x1) = .Range(y1).value
        Sheets(S).Range(x1) = y1
       
'        x1 = Sheets("data").Cells(y, 11).value   'x
'        y1 = Format(Sheets("data").Cells(y, 10).value, "MM/dd/yyyy")       'y
'''        'Sheets(s).Range(x1) = .Range(y1).value
'        Sheets(s).Range(x1) = y1
       
        NbLig = nl  'Application.CountIf(Feuil1.Range("A10:A196"), ">0") ' Calcul Nb lignes utiles
        Start = Sheets("data").Cells(y, 14).value ' start
        Ends = Start + 187 ' et Ends
        'Sheets(S).Rows(Start & ":" & Ends).Hidden = False
        'nb1 = Sheets("data").Cells(y, 16).value ' nblign2 une page +-
        'nb2 = Sheets("data").Cells(y, 17).value ' nblign2 deux pages +-
        'nb3 = Sheets("data").Cells(y, 18).value ' nblign2 trois pages +-
       
        'If nb1 < NbLig And NbLig < nb2 Then NbLig = nb2
        'If NbLig > nb2 Then NbLig = nb3
        'If NbLig <= nb1 Then NbLig = nb1
        'If Sheets("data").Cells(y, 22) < NbLig < Sheets("data").Cells(y, 23) Then
        'NbLig = Sheets("data").Cells(y, 22)
        'pg = 0
       
        'Sheets("data").Cells(y, 19) = NbLig
        Sheets(S).Rows(Start + NbLig & ":" & Ends).Hidden = True ' Masque les lignes vides.
        'Sheets(nom).Activate                ' Selection feuille pour mise à jour
        'Sheets(s).Activate                ' Selection feuille pour mise à jour
        Sheets(S).Rows(Start & ":" & Start + NbLig).AutoFit
        With Sheets(S).PageSetup
        'If NbLig > 40 Then .CenterFooter = "Page &P de &N" Else .CenterFooter = ""
        If Sheets(S).PageSetup.Pages.Count > 1 Then .CenterFooter = "Page &P de &N" Else .CenterFooter = ""
        End With
'If y = 5 Or y = 6 Then
'Sheets(s).Range("A" & Start & ":E" & End).ClearContents
'Else
'Sheets(s).Range("A" & Start & ":D" & End).ClearContents
'End If
'    For l = Start To Start + NbLig
'    Cells(l, "E") = Cells(l, "C") * Cells(l, "D") ' montant TTC
'    If Cells(l, "E") = 0 Then Cells(l, "E") = ""
'    Next l
'    End With
    'Next x
    Next y
    End With
Feuil6.Rows(nl + 19 & ":" & Ends).Hidden = True ' Masque les lignes vides.
Feuil15.Rows(nl + 5 & ":" & Ends).Hidden = True ' Masque les lignes vides.
'Call sendfile
'Application.ScreenUpdating = True
End Sub

SHEETS Y/X

DATA 01

DATA 02

DATA 03

DATA 04

DATA 05

DATA 06

SHEET2

formula-0-1

A203

formula-1-1

B9

formula-1-1

B10

formula-2-1

B11

formula-3-1

B12

formula-4-1

E11

SHEET3

formula-0-2

A205

formula-1-2

C8

formula-1-1

B9

formula-2-1

B10

formula-4-2

E10

SHEET4

formula-0-3

A203

formula-1-3

A10

formula-1-1

B11

formula-2-1

B12

formula-4-3

E11

SHEET5

formula-0-4

C206

formula-1-4

E3

formula-1-1

F6

formula-2-1

F8

formula-3-1

D4

formula-4-4

G4

SHEET6

formula-1-5

F3

formula-1-1

F8

formula-2-1

F10

formula-3-1

D4

formula-4-5

G4

SHEET7

formula-1-6

B5

formula-2-1

B7

formula-4-1

E6

SHEET15

formula-1-1

C1

formula-1-1

A2

formula-2-1

C1

formula-3-1

B4

formula-4-1

B3

SHEET14

formula-1-1

C1

formula-1-1

A4

formula-4-1

E4

SHEET16

formula-1-1

G3

formula-1-1

A2

formula-4-1

SHEET1

Adress

1

2

3

4

5

6

7

8

9

10

11

12

13

offthelip · Apr 24, 2023

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.
I have made some very simple modification to your code simply by loading the data from the "data" sheet into a variant array. this will speed up your a lot because you have a double loop ( Y and then x) with multiple accesses to the worksheet. I have left the workhseet accesses where you are writing back tothe worksheet. thse could be changed if you want to speed it up more.

VBA Code:

Sub update3()
Dim X%, y%, NbLig%, Start%, Ends%, nb1%, nb2%, nb3%, lim%, nl%
Dim x1$, y1$, S$, w
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim rng As Range

nl = Application.CountIf(Feuil1.Range("B10:A196"), ">0")

'Grab Some Data and Store it in a "Range" variable
Set rng = Feuil1.Range("S10:S" & nl + 10)
'Transfer Values to same spot in another worksheet (Mimics PasteSpecial Values Only)
Feuil1.Range("B10").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value

Sheets("data").Range("O13") = nl
' load all the data for the DATa sheet into a variant array:
inarr = Worksheets("data").Range(Cells(1, 1), Cells(8, 14))
    Call snb2
    With Feuil1
        For y = 2 To 8
'        S = Sheets("data").Cells(y, 1).Value       'sheet
        S = inarr(y, 1)       'sheet
       
        For X = 2 To 10 Step 2 ' 8
        x1 = inarr(y, X + 1)   'x
        y1 = inarr(y, X)       'y
        'Sheets(s).Range(x1) = .Range(y1).value
        Sheets(S).Range(x1) = y1
        Next X
        ' date
        x1 = inarr(y, 13)   'x
        y1 = Format(Sheets("data").Cells(y, 12).Value, "MM/dd/yyyy")    'y
        'Sheets(s).Range(x1) = .Range(y1).value
        Sheets(S).Range(x1) = y1
       
'        x1 = Sheets("data").Cells(y, 11).value   'x
'        y1 = Format(Sheets("data").Cells(y, 10).value, "MM/dd/yyyy")       'y
'''        'Sheets(s).Range(x1) = .Range(y1).value
'        Sheets(s).Range(x1) = y1
       
        NbLig = nl  'Application.CountIf(Feuil1.Range("A10:A196"), ">0") ' Calcul Nb lignes utiles
        Start = inarr(y, 14).Value ' start
        Ends = Start + 187 ' et Ends
        'Sheets(S).Rows(Start & ":" & Ends).Hidden = False
        'nb1 = Sheets("data").Cells(y, 16).value ' nblign2 une page +-
        'nb2 = Sheets("data").Cells(y, 17).value ' nblign2 deux pages +-
        'nb3 = Sheets("data").Cells(y, 18).value ' nblign2 trois pages +-
       
        'If nb1 < NbLig And NbLig < nb2 Then NbLig = nb2
        'If NbLig > nb2 Then NbLig = nb3
        'If NbLig <= nb1 Then NbLig = nb1
        'If Sheets("data").Cells(y, 22) < NbLig < Sheets("data").Cells(y, 23) Then
        'NbLig = Sheets("data").Cells(y, 22)
        'pg = 0
       
        'Sheets("data").Cells(y, 19) = NbLig
        Sheets(S).Rows(Start + NbLig & ":" & Ends).Hidden = True ' Masque les lignes vides.
        'Sheets(nom).Activate                ' Selection feuille pour mise à jour
        'Sheets(s).Activate                ' Selection feuille pour mise à jour
        Sheets(S).Rows(Start & ":" & Start + NbLig).AutoFit
        With Sheets(S).PageSetup
        'If NbLig > 40 Then .CenterFooter = "Page &P de &N" Else .CenterFooter = ""
        If Sheets(S).PageSetup.Pages.Count > 1 Then .CenterFooter = "Page &P de &N" Else .CenterFooter = ""
        End With
'If y = 5 Or y = 6 Then
'Sheets(s).Range("A" & Start & ":E" & End).ClearContents
'Else
'Sheets(s).Range("A" & Start & ":D" & End).ClearContents
'End If
'    For l = Start To Start + NbLig
'    Cells(l, "E") = Cells(l, "C") * Cells(l, "D") ' montant TTC
'    If Cells(l, "E") = 0 Then Cells(l, "E") = ""
'    Next l
'    End With
    'Next x
    Next y
    End With
Feuil6.Rows(nl + 19 & ":" & Ends).Hidden = True ' Masque les lignes vides.
Feuil15.Rows(nl + 5 & ":" & Ends).Hidden = True ' Masque les lignes vides.
'Call sendfile
'Application.ScreenUpdating = True
End Sub

chingilou · Apr 27, 2023

hello, thank you for the valuable information you gave me and sorry for having delayed answering you I am just trying to put all my data to be transmitted in the table and to find solutions for the 1004 error and I I will answer you after
thanks in advance again

fast way to CopyPaste Non-Contiguous cells

chingilou

New Member

Attachments

Excel Facts

offthelip

Well-known Member

chingilou

New Member

Similar threads

Forum statistics

Share this page

fast way to CopyPaste Non-Contiguous cells

chingilou

New Member

Attachments

Excel Facts

offthelip

Well-known Member

chingilou

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock