fast way to CopyPaste Non-Contiguous cells

C

chingilou

New Member
Joined
Feb 10, 2019
Messages
6
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/XDATA 01DATA 02DATA 03DATA 04DATA 05DATA 06
SHEET2formula-0-1A203formula-1-1B9formula-1-1B10formula-2-1B11formula-3-1B12formula-4-1E11
SHEET3formula-0-2A205formula-1-2C8formula-1-1B9formula-2-1B10formula-4-2E10
SHEET4formula-0-3A203formula-1-3A10formula-1-1B11formula-2-1B12formula-4-3E11
SHEET5formula-0-4C206formula-1-4E3formula-1-1F6formula-2-1F8formula-3-1D4formula-4-4G4
SHEET6formula-1-5F3formula-1-1F8formula-2-1F10formula-3-1D4formula-4-5G4
SHEET7formula-1-6B5formula-2-1B7formula-4-1E6
SHEET15formula-1-1C1formula-1-1A2formula-2-1C1formula-3-1B4formula-4-1B3
SHEET14formula-1-1C1formula-1-1A4formula-4-1E4
SHEET16formula-1-1G3formula-1-1A2formula-4-1
SHEET1SHEET1SHEET1SHEET1SHEET1SHEET1
AdressAdressAdressAdressAdressAdress
12345678910111213
 

Attachments

  • n_2.jpg
    n_2.jpg
    128.6 KB · Views: 13
Last edited by a moderator:

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
How to copy data from single cells to merge cells and vice versa
2 3
Replies
24
Views
444
Alex Blakenburg
A
C
  • Question
Finding any two values in each cell text in a column of cells with both values as one Textbox1 variable
2
Replies
10
Views
232
chazrab
C
K
  • Solved
Jump to cell after clicking message box ok
Replies
3
Views
99
dreid1011
dreid1011
T
  • Solved
VBA
Replies
6
Views
188
twildone
T
K
  • Question
Excel Macro to Save to .pdf not working
Replies
9
Views
300
kpost
K

Forum statistics

Threads
1,215,045
Messages
6,122,840
Members
449,096
Latest member
Erald

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