VBA - Copying Non-Contiguous Ranges in/out of (an) Array(s)

beartooth91

Board Regular
Joined
Dec 15, 2024
Messages
69
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
I have lots of worksheets which routinely get copied into a master sheet. The VBA for one example is below. Everything works but it does get a bit slow as each sheet gets copied from. I'm wondering if using an array - or arrays - would speed it up? The main problem is the copy from / paste to data is in non-contiguous ranges.

VBA Code:
Sub Import_109C_IOList_New()
'
' NOTE: This macro is for 109 column instrument templates!
' It copies data from a 109-Column IO/Instrument List in the Non-Standard IO Lists folder to a new worksheet in the Master IO List workbook.
'
'------------------------------Copy all the below into each non-std IO List import sub
'Declare Variables-------------------------------------------------------------------------------
Dim sheetExists As Boolean
Dim StartRow As Long, LastRow As Long
Dim wsname As String
Dim nme() As String
Dim wbMaster As Workbook, wbOpened As Workbook  '<-----use this instead of wbname?
Dim wS As Worksheet

Set wbMaster = Workbooks("NIC Master IO List.xlsm")
Set wbOpened = ActiveWorkbook
 
  With wbOpened.Sheets(1)
    nme = Split(.Cells(11, "M").Value, "-", -1)  '<-----These two lines need moved into the subs for non-standard IO import
    wsname = nme(1)  '<-------------------------------
  End With
  'wbMaster.Activate  '<----Is this needed?
  With wbMaster
    For Each wS In .Worksheets
      If wS.Name = wsname Then
         sheetExists = True
         '------------------------------------r1
         'GoTo ThisLine        'Or use Exit For (next line)
         Exit For
      Else                    '<---------------Is this needed?
         sheetExists = False
      End If
    Next
    '------------------------------------------r1

    ' Adjust the below for current import sub Copy/Destination code
    If Not sheetExists Then
           wbMaster.Sheets(1).Copy After:=wbMaster.Sheets(wbMaster.Worksheets.Count)
           ActiveSheet.Name = wsname
           
           '.Sheets("NewSheet").Name = wsname
    End If
    '-------------------------------------------
    StartRow = .Sheets(wsname).Cells(Rows.Count, "B").End(xlUp).Row + 1
  End With
   
'ThisLine:
  'wbOpened.Activate--------------------??
  With wbOpened.Sheets(1)
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    '<-------------------------------------------r1
    'Deleted the If Then Else, kept the copy/paste
'
'Copy Component Number
    wbOpened.Worksheets(1).Range("M11:M" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("B" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Unit Number
    wbOpened.Worksheets(1).Range("B11:B" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("C" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy System Desig, CC, Seq Number, and Parallel Desig
    wbOpened.Worksheets(1).Range("D11:G" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("D" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Channel/Div
    wbOpened.Worksheets(1).Range("K11:K" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("H" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Desc, Noun Name, Design Phase, Bldg, Location, Elevation, Doc/Dwg, Datasheet, Parent, Safety Class, Safety Function
    wbOpened.Worksheets(1).Range("N11:Y" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("I" & StartRow).PasteSpecial Paste:=xlPasteValues

'Copy Class 1E
    wbOpened.Worksheets(1).Range("AC11:AC" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("X" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Voltage, SDG, and Off-Site Power Feed
    wbOpened.Worksheets(1).Range("AF11:AH" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("Y" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Weight, MR/PR, Vendor Supplied, Fab Cat, Dest, Vendor Ins, Manufacturer, Model, Equip No.
    wbOpened.Worksheets(1).Range("AL11:AT" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("AC" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Resp Design Org and Remarks
    wbOpened.Worksheets(1).Range("BA11:BB" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("AM" & StartRow).PasteSpecial Paste:=xlPasteValues
'Copy Instrument Data Fields
    wbOpened.Worksheets(1).Range("BF11:CF" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("AO" & StartRow).PasteSpecial Paste:=xlPasteValues

  wbOpened.Close
End With

    'Formatting
    Workbooks("NIC Master IO List.xlsm").Activate '<----
    fr = Cells(1, 1).SpecialCells(xlLastCell).Row
    Workbooks("NIC Master IO List.xlsm").Worksheets("Instrument List Template").Range("B11:BO11").Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("B11:BO" & fr).PasteSpecial Paste:=xlPasteFormats
    '
    Application.ScreenUpdating = True
    
    Application.CutCopyMode = False
    Workbooks("NIC Master IO List.xlsm").Save
 '
End Sub
 
Ref Post #3
1) pasting the value starts in Column B only and not from A.
2)These lines are changed. It is to be kept as it is.
VBA Code:
'Copy Instrument Data Fields
    wbOpened.Worksheets(1).Range("BF11:CF" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("AO" & StartRow).PasteSpecial Paste:=xlPasteValues

These lines are Included in my code.
VBA Code:
'Copy Resp Design Org and Remarks
    wbOpened.Worksheets(1).Range("BA11:BB" & LastRow).Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("AM" & StartRow).PasteSpecial Paste:=xlPasteValues
Code for these lines is
VBA Code:
.Offset(0, Range("AM1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BA1").Column)
.Offset(0, Range("AN1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BB1").Column)
Just change the code as told in Post#2. Try the code on a copy of file
 
Upvote 0

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
I'm wondering if using an array - or arrays - would speed it up? The main problem is the copy from / paste to data is in non-contiguous ranges.
Although you have quite a few non-contiguous ranges in the source worksheet, you only have four non-contiguous ranges in the destination worksheet.
Here is a method that produces the same results (from my testing anyway) as your code without using copy/paste or arrays as the values can be transferred directly. I think that you should find it pretty fast.
This code only deals with the transfer of the results to the destination worksheet, not the formatting as I don't have access to the relevant formatting
I have also changed a bit of the code towards the top of the code.
I have only tested when the destination worksheet does exists.
I am assuming use in an Excel version with the SEQUENCE & TEXTJOIN functions but that could be changed.
Give it a try with a copy of your workbook.
VBA Code:
Sub Import_109C_IOList_New_v2()
  'Declare Variables-------------------------------------------------------------------------------
  Dim sheetExists As Boolean
  Dim StartRow As Long, LastRow As Long, rws As Long
  Dim wsname As String
  Dim nme() As String
  Dim wbMaster As Workbook, wbOpened As Workbook
  Dim wsSource As Worksheet, wsDest As Worksheet
  Dim fr As Long
  Dim vRws As Variant, vCols As Variant

  Set wbMaster = Workbooks("NIC Master IO List.xlsm")
  Set wbOpened = ActiveWorkbook
  Set wsSource = wbOpened.Sheets(1)

  nme = Split(wsSource.Cells(11, "M").Value, "-", -1)
  wsname = nme(1)
  
  With wbMaster
    On Error Resume Next
    sheetExists = .Sheets(wsname).Name <> ""
    On Error GoTo 0
    If Not sheetExists Then
           .Sheets(1).Copy After:=.Sheets(wbMaster.Worksheets.Count)
           ActiveSheet.Name = wsname
    End If
  End With
  
  Set wsDest = wbMaster.Worksheets(wsname)
  StartRow = wsDest.Cells(Rows.Count, "B").End(xlUp).Row + 1
   
  With wsSource
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    rws = LastRow - 10
  
    'Set rows to be copied
    vRws = Application.Sequence(rws, , 11)
    
    'Fill section 1
    vCols = Split(Application.TextJoin(" ", 0, 2, 4, 5, 6, 7, 11, Application.Sequence(, 13, 13)))
    wsDest.Range("B" & StartRow).Resize(rws, UBound(vCols) + 1).Value = Application.Index(.Cells, vRws, vCols)
  
    'Fill section 2
    vCols = Split("29 32 33 34")
    wsDest.Range("X" & StartRow).Resize(rws, UBound(vCols) + 1).Value = Application.Index(.Cells, vRws, vCols)
      
    'Fill section 3
    vCols = Application.Sequence(, 9, 38)
    wsDest.Range("AC" & StartRow).Resize(rws, UBound(vCols)).Value = Application.Index(.Cells, vRws, vCols)
    
    'Fill section 4
    vCols = Split(Application.TextJoin(" ", 0, 53, 54, Application.Sequence(, 27, 58)))
    wsDest.Range("AM" & StartRow).Resize(rws, UBound(vCols) + 1).Value = Application.Index(.Cells, vRws, vCols)
      
    wbOpened.Close
  End With
End Sub
 
Last edited:
Upvote 0
I have made changes in your code. Don't do any change. Just try on the copy of file.
VBA Code:
Sub Import_109C_IOList_New()
'
' NOTE: This macro is for 109 column instrument templates!
' It copies data from a 109-Column IO/Instrument List in the Non-Standard IO Lists folder to a new worksheet in the Master IO List workbook.
'
'------------------------------Copy all the below into each non-std IO List import sub
'Declare Variables-------------------------------------------------------------------------------
Dim sheetExists As Boolean
Dim StartRow As Long, LastRow As Long
Dim wsname As String
Dim nme() As String
Dim wbMaster As Workbook, wbOpened As Workbook  '<-----use this instead of wbname?
Dim wS As Worksheet

Set wbMaster = Workbooks("NIC Master IO List.xlsm")
Set wbOpened = ActiveWorkbook
 
  With wbOpened.Sheets(1)
    nme = Split(.Cells(11, "M").Value, "-", -1)  '<-----These two lines need moved into the subs for non-standard IO import
    wsname = nme(1)  '<-------------------------------
  End With
  'wbMaster.Activate  '<----Is this needed?
  With wbMaster
    For Each wS In .Worksheets
      If wS.Name = wsname Then
         sheetExists = True
         '------------------------------------r1
         'GoTo ThisLine        'Or use Exit For (next line)
         Exit For
      Else                    '<---------------Is this needed?
         sheetExists = False
      End If
    Next
    '------------------------------------------r1

    ' Adjust the below for current import sub Copy/Destination code
    If Not sheetExists Then
           wbMaster.Sheets(1).Copy After:=wbMaster.Sheets(wbMaster.Worksheets.Count)
           ActiveSheet.Name = wsname
           
           '.Sheets("NewSheet").Name = wsname
    End If
    '-------------------------------------------
    StartRow = .Sheets(wsname).Cells(Rows.Count, "B").End(xlUp).Row + 1
  End With
   
'ThisLine:
  'wbOpened.Activate--------------------??
  With wbOpened.Sheets(1)
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    '<-------------------------------------------r1
    'Deleted the If Then Else, kept the copy/paste
'
Dim Ary, Ary1
Ary = wbOpened.Worksheets(1).Range("A11:BB" & LastRow)
Ary = wbOpened.Worksheets(1).Range("BF11:CF" & LastRow)

With Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("A" & StartRow).Resize(LastRow - 10, 1)
.Offset(0, Range("B1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("M1").Column)
.Offset(0, Range("C1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("B1").Column)
.Offset(0, Range("D1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("D1").Column)
.Offset(0, Range("H1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("K1").Column)
.Offset(0, Range("I1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("N1").Column)
.Offset(0, Range("X1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AC1").Column)
.Offset(0, Range("Y1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AF1").Column)
.Offset(0, Range("AC1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AL1").Column)
.Offset(0, Range("AM1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BA1").Column)
.Offset(0, Range("AN1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BB1").Column)
.Offset(0, Range("AO1").Column - 1).Resize(, Range("CF1").Column - Range("BF1").Column + 1) = WorksheetFunction.Index(Ary1, 0, 0)
End With

  wbOpened.Close
End With

    'Formatting
    Workbooks("NIC Master IO List.xlsm").Activate '<----
    fr = Cells(1, 1).SpecialCells(xlLastCell).Row
    Workbooks("NIC Master IO List.xlsm").Worksheets("Instrument List Template").Range("B11:BO11").Copy
    Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("B11:BO" & fr).PasteSpecial Paste:=xlPasteFormats
    '
    Application.ScreenUpdating = True
    
    Application.CutCopyMode = False
    Workbooks("NIC Master IO List.xlsm").Save
 '
End Sub
 
Upvote 0
Tested and works! Thank You!
 
Upvote 0
This one is giving the 'Unable to get the Index property of the WorksheetFunction class' run time error at the line marked below.
VBA Code:
With Workbooks("NIC Master IO List.xlsm").Worksheets(wsname).Range("A" & StartRow).Resize(LastRow - 10, 1)
.Offset(0, Range("B1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("M1").Column)
.Offset(0, Range("C1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("B1").Column)
.Offset(0, Range("D1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("D1").Column)
.Offset(0, Range("H1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("K1").Column)
.Offset(0, Range("I1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("N1").Column)
.Offset(0, Range("X1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AC1").Column)  '<-------Unable to get the Index property of the WorksheetFunction class' run time error
.Offset(0, Range("Y1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AF1").Column)
.Offset(0, Range("AC1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("AL1").Column)
.Offset(0, Range("AM1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BA1").Column)
.Offset(0, Range("AN1").Column - 1) = WorksheetFunction.Index(Ary, 0, Range("BB1").Column)
.Offset(0, Range("AO1").Column - 1).Resize(, Range("CF1").Column - Range("BF1").Column + 1) = WorksheetFunction.Index(Ary1, 0, 0)
End With
 
Upvote 0
This works as well. Thank you!
 
Upvote 0
Tested and works!

This works as well.
Good to know and thanks for telling us. (y)

However, you said your original code worked too and your question was really about speed but you have not given any feedback about that. :)
Did the working codes make a significant difference?

BTW, about how many rows of data does the code normally move to the other sheet?
 
Upvote 0
Good to know and thanks for telling us. (y)

However, you said your original code worked too and your question was really about speed but you have not given any feedback about that. :)
Did the working codes make a significant difference?

BTW, about how many rows of data does the code normally move to the other sheet?
Ummm.....yeah...... The current 109 column sheets only have about 20 rows of data (I didn't realize that), so I don't see much difference. However comma the 65/90/95 column versions can have hundreds to 1500+ data rows. So, I need to study and port the codes over to those to answer your question. Currently, there are 6 or 7 of these and you do see the slow down after each Range.Copy and write. (The copying of each worksheet is automated so the master cycles through the subfolder with all of these.) And there may be more of these non-standard worksheets coming.
 
Upvote 0

Forum statistics

Threads
1,226,462
Messages
6,191,177
Members
453,644
Latest member
karlpravin

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