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

B

beartooth91

Board Regular
Joined
Dec 15, 2024
Messages
63
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
 
Sort by date Sort by votes
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

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
beartooth91 said:
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.
Click to expand...
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
DanteAmor said:
I rewrote your macro to put the source data into an array.
And pass column by column to the destination sheet.

Question:
What do you have in the columns where data will not be pasted, for example columns "A", "V", "W", "AB", etc?
Do You have data or formulas or it is simply empty?
Because if they are empty, the macro can be improved and should be faster.

For the macro:
On this line you must put the source column, the destination column and the number of continuous columns to copy.
VBA Code: 
arr = Array("M", "B", 1, "B", "C", 1, "D", "D", 4, "K", "H", 1, "N", "I", 12, "AC", "X", 1, _
                "AF", "Y", 3, "AL", "AC", 9, "BA", "AM", 2, "BF", "AO", 2, "BF", "AO", 27)

For example:
Rich (BB code): 
'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
Source Column "D"
Destination Column "D"
Number of continuous columns 4

Then:
Rich (BB code): 
arr = Array("M", "B", 1, "B", "C", 1, "D", "D", 4, "K", "H", 1, "N", "I", 12, "AC", "X", 1, _
                "AF", "Y", 3, "AL", "AC", 9, "BA", "AM", 2, "BF", "AO", 2, "BF", "AO", 27)

Try this:
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
  Dim wsname As String
  Dim nme() As String
  Dim wbMaster As Workbook, wbOpened As Workbook  '<-----use this instead of wbname?
  Dim wS As Worksheet
  Dim fr As Long
  Dim a As Variant, arr As Variant
  Dim i As Long, k As Long, j As Long, y As Long, m As Long
 
  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)                               '<-------------------------------
    a = .Range("A11:CF" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With wbMaster
    sheetExists = False
    For Each wS In .Worksheets
      If UCase(wS.Name) = UCase(wsname) Then
         sheetExists = True
         Exit For
      End If
    Next
   
    If Not sheetExists Then
      .Sheets(1).Copy After:=.Sheets(.Worksheets.Count)
      .Sheets(.Worksheets.Count).Name = wsname
    End If
    '-------------------------------------------
    StartRow = .Sheets(wsname).Cells(Rows.Count, "B").End(xlUp).Row + 1
 
    arr = Array("M", "B", 1, "B", "C", 1, "D", "D", 4, "K", "H", 1, "N", "I", 12, "AC", "X", 1, _
                "AF", "Y", 3, "AL", "AC", 9, "BA", "AM", 2, "BF", "AO", 2, "BF", "AO", 27)
    For y = 0 To UBound(arr) Step 3
      ReDim b(1 To UBound(a), 1 To arr(y + 2))
      k = 0
      For i = 1 To UBound(a)
        k = k + 1
        m = 0
        For j = Columns(arr(y)).Column To Columns(arr(y)).Column + arr(y + 2) - 1
          m = m + 1
          b(k, m) = a(i, j)
        Next
      Next
      .Sheets(wsname).Range(arr(y + 1) & StartRow).Resize(UBound(b), UBound(b, 2)).Value = b
    Next
 
  End With
 
  wbOpened.Close

  '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
Click to expand...
Tested and works! Thank You!
DanteAmor said:
😇
Click to expand...
 
Upvote 0
kvsrinivasamurthy said:
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
Click to expand...
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
Peter_SSs said:
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
Click to expand...
This works as well. Thank you!
 
Upvote 0
beartooth91 said:
Tested and works!
Click to expand...

beartooth91 said:
This works as well.
Click to expand...
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
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA - Subscript Out of Range Error When Checking if a Worksheet Exists
2
Replies
11
Views
165
DanteAmor
DanteAmor
B
  • Solved
Better Way to Copy Rows Out of a Loop?
2
Replies
11
Views
240
dmt32
D
J
  • Solved
Speeding up VBA
Replies
9
Views
311
jvoss
J
Z
  • Solved
Run-time error 9
2
Replies
12
Views
290
zerofeng
Z
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
470
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,225,534
Messages
6,185,500
Members
453,298
Latest member
Adam1258

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