Subscription out of range

[ashani]

Hi
I'm trying to copy specific data from one workbook to another workbook. I'm using the following code and getting error message "Subscription out of range" - please can someone help me with this.

Option Explicit
Option Base 1
Sub CopyTo()
    Dim Cel As Range
    Dim wsc As Worksheet, wst As Worksheet
    Dim wbc As Workbook, wbt As Workbook
    Dim arrc, arrt
    Dim k&, i&, j&, m&
    Dim mydata As Workbook

    Set wbc = ThisWorkbook
    Set wsc = wbc.Worksheets("sheet1")
    arrc = wsc.[A85:D93]
    k = 1: m = 0
    ReDim arrt(1, UBound(arrc, 1) * (UBound(arrc, 2) - 1))
    For i = 1 To UBound(arrc, 1)
        For j = 2 To UBound(arrc, 2)
            arrt(k, m + j - 1) = arrc(i, j)
        Next j
        m = m + 5
    Next i
    
    Set mydata = Workbooks.Open("C:\Users\mybook.xlsx")
    Set wbt = Workbooks("mybook.xlsx")
    Set wst = wbt.Worksheets("Data")
    i = WorksheetFunction.Match(UCase(wsc.[t3]), wst.[a5:a82], 0)
    wst.Cells(i, 2).Resize(UBound(arrt, 1), UBound(arrt, 2)) = arrt

mydata.Save
mydata.Close


End Sub

 

[Fluff]

Which line of code gives that error?

 

[ashani]

arrt(k, m + j - 1) = arrc(i, j)

 

[ashani]

If I change this to a5:d14

Set wbc = ThisWorkbook
Set wsc = wbc.Worksheets("sheet1")
arrc = wsc.[A85:D93]

and

i = WorksheetFunction.Match(UCase(wsc.[t3]), wst.[a5:a82], 0)

to a1:a10

then it works fine otherwise error message

 

[Fluff]

What are you trying to do with the arrt?
At the moment you are bringing in data from cols B,C & D, & then leaving two empty slots.

 

[ashani]

That’s exactly I want to do to data from all columns from col b to aa and don’t leave any empty slots in the middle.
thank you

 

[Fluff]

In that case try

Option Base 1
Sub CopyTo()
    Dim Cel As Range
    Dim wsc As Worksheet, wst As Worksheet
    Dim wbc As Workbook, wbt As Workbook
    Dim arrc, arrt
    Dim k&, i&, j&, m&
    Dim mydata As Workbook

    Set wbc = ThisWorkbook
    Set wsc = wbc.Worksheets("pcode")
    arrc = wsc.[B85:D93]
    k = 1: m = 0
    ReDim arrt(1, UBound(arrc, 1) * (UBound(arrc, 2)))
    For i = 1 To UBound(arrc, 1)
        For j = 1 To UBound(arrc, 2)
            arrt(k, m + j) = arrc(i, j)
        Next j
        m = m + UBound(arrc, 2)
    Next i
    
    Set mydata = Workbooks.Open("C:\Users\mybook.xlsx")
    Set wbt = Workbooks("mybook.xlsx")
    Set wst = wbt.Worksheets("Data")
    i = WorksheetFunction.Match(UCase(wsc.[t3]), wst.[a5:a82], 0)
    wst.Cells(i, 2).Resize(UBound(arrt, 1), UBound(arrt, 2)) = arrt

mydata.Save
mydata.Close


End Sub

 

[ashani]

absolutely star - thank you so much
really apprecicate your help.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[ashani]

Hi,
Can I ask a quick question in regards to the above syntax :
Currently, if there is no value in T3 then it comes up with an error message. Is it possible to have message box instead of error message to say "Please select region"?
Many thanks once again,