Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

copy non adjacent cells from sheet to another

0

hi

 I  need  fixing    this   error,    it  should   copy  specific  ranges   from  sheet   to  another  

it  shows  me  error  subscript out of range  in this  line

 r.Value = a(1, i)
Sub test()
    Dim a, r As Range, i As Long
    a = Sheets("SavedSpecs").Range("a" & Rows.Count).End(xlUp).Resize(, 5).Value
    For Each r In Worksheets("Cover").Range("A3:B6, E6:E16")
        i = i + 1
        r.Value = a(1, i)
    Next
End Sub

any helps   I truly appreciate

Answer
Discuss

Answers

1
Selected Answer

Leap

I'm not sure what you're trying to do here but the sheet SavedSpecs is empty (apart from row 1) so your line 

a = Sheets("SavedSpecs").Range("a" & Rows.Count).End(xlUp).Resize(, 5).Value
creates an array with just 5 entries (from SavedSpecs $A$1:$E$1). 

Your code then tries to loop through a split range in Cover, copying these values.There are only 5 entries so when i reaches 6, VBA sees an error ("where's the 6th array entry?").

In the attached version of your updated workbook, I see that your data sheet has a strange design (to my mind) so I've taken the simple approach of copying the blocks of data to set destinations in result then using a loop (like yours) to get the "spilt" data into a horizontal format (as your example showed).

REVISION: The macro below is extended to add the data to that existting on the destination sheet result, add item numbers in column A, add borders to the copied values plus give a message when that's done. It does NOT delete the entries in the source sheet data (I leave that for you to do that, once tested and if needed). Here is the revised code, with comments (and recent changed parts indicated in bold):

Sub CopyData()
'
' Macro to copy split ranges
'
'
Dim WsSrc As Worksheet, WsDest As Worksheet
Dim RwUp As Integer, RwLow As Integer, RwDest As Integer, i As Integer

Application.ScreenUpdating = False

Set WsSrc = Worksheets("data")
Set WsDest = Worksheets("result")

'find next destination data row
RwDest = Range("A" & Rows.Count).End(xlUp).Row + 1

RwUp = WsSrc.Range("A17").End(xlUp).Row 'find last row used in upper part of WsSrc
RwLow = WsSrc.Range("A32").End(xlUp).Row 'find last row used in lower part of WsSrc

'copy/ map blocks of data:
WsSrc.Range("A8:E" & RwUp).Copy
WsDest.Range("B" & RwDest).PasteSpecial Paste:=xlPasteValues
WsSrc.Range("A21:A" & RwLow).Copy
WsDest.Range("G" & RwDest).PasteSpecial Paste:=xlPasteValues
WsSrc.Range("E21:F" & RwLow).Copy
WsDest.Range("H" & RwDest).PasteSpecial Paste:=xlPasteValues

' Get non-contiguous data and copy values horizontally
For Each Splt In WsSrc.Range("B37, E36, C18, C19, D4, D5, H4")
    'place value horizontally
    WsDest.Range("J" & RwDest).Offset(0, i).Value = Splt.Value

    i = i + 1

Next Splt

' add item no. in column A of Destination (partly unpopulated to start so count rows now in B)
For i = RwDest To WsDest.Range("B" & Rows.Count).End(xlUp).Row
    WsDest.Range("A" & i).Value = i + 1 - RwDest
Next i

' add borders to used range...
With WsDest.UsedRange.Borders
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .Weight = xlThin
End With

WsDest.Range("A" & i).Select

Application.CutCopyMode = False

Application.ScreenUpdating = True

i = MsgBox("Data transferred", vbOKOnly)

End Sub
Hope this works for you.
Discuss

Discussion

thanks
first  sorry  I  don't   expleain  clearly   ,my  idea  is  choosing  the  non  adjacant  cells   should  copy  from sheet  to  another   beleow  is  relating  the  header   second  if  I  understand youe    correctly  the  value  should  be  4   not  5  as  in  array  according  my  data  if  it's  so     also   shows  the  error  so   what  I  choose  the  ranges ("A3:B6, E6:B16)  should  copy   under  the  COL A ,E   based on the  headers  as  in  existed  in first sheet ,  may  be  you  see  that  is  not  logic  to   choose  like theses ranges  but   I  will test  that    for   a real  my  data
leap (rep: 46) Jun 15, '21 at 2:34 am
Leap

Sorry but I can't understand your discussion point above.

My point is that you are 1) popuating an array with values from 5 cells in the last row of SavedSpecs,  2) trying to copy those 5 values into a range in Cover of 19 cells (A3:B6 = 8 cells plus  E6:E16 =11 cells) so VBA will always fail 14 cells short.

Please edit your original question add a better xeplanation or better example file e.g. show an example of cells you want to copy (in a colour) and where you want the results to appear (in another colour), saying if the recipient sheet is to be cleared or added to.
John_Ru (rep: 6102) Jun 15, '21 at 3:38 am
I  update  the  file ,  any  cells  highlighted  by  green  in sheet DATA should  copy  to sheet  result  i put  the  headers  in  sheet  before  and  expected  result  should  be  in sheet  result
leap (rep: 46) Jun 15, '21 at 4:59 am
Thanks Leap. I'm busy today so it might be ~8 hours before I can reply. Others might reply in the meantime perhaps. 
John_Ru (rep: 6102) Jun 15, '21 at 5:59 am
Leap. Sorry but I found your workbook simply confusing. See my revised answer for a crude solution (which should work). 
John_Ru (rep: 6102) Jun 15, '21 at 6:24 pm
thanks   but  it  should   add   to  the  bottom  data  already  are  existed  but  the  code  replace  a new  data  for   old  data   and  the  column  A (ITEM)  should  be  1,2,3 and  so  on 
leap (rep: 46) Jun 16, '21 at 4:29 am
Leap

You say it should "replace  a new  data  for   old  data" (which I assume means replace old data with new) but I already asked you above if that was needed and you didn't reply.

I think you should be able to do that (and add item numbers) but will revise my answer anyway
John_Ru (rep: 6102) Jun 16, '21 at 5:34 am
Please see revised Answer
John_Ru (rep: 6102) Jun 16, '21 at 5:47 am
thanks  
It still doesn't  copy   under  the  data  are  alredy  existes  in sheet  result  
I  think  this  line  what  causes  that
WsDest.Range("A3:P" & Range("A" & Rows.Count).End(xlUp).Row + 1).EntireRow.Delete
 
I amended  to  become  this 
WsDest.Range("A3:P" & Range("A" & Rows.Count).End(xlUp).Row + 1)

but  it  gives error  compile error in this  word
. range 
thanks again
leap (rep: 46) Jun 16, '21 at 6:24 am
Leap

I thought you wanted to delete old data. I have now revised my answer to correct that.
John_Ru (rep: 6102) Jun 16, '21 at 6:38 am
it works greatly !
thanks  for  your time and  cooperation 
leap (rep: 46) Jun 16, '21 at 6:50 am
That's good Leap.

Next time, please try to make your question clear and complete.
John_Ru (rep: 6102) Jun 16, '21 at 6:59 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login