VBA: error message in r.Copy output_sheet

Question

i got a problem when trying to copy my data from sheet1 into sheet2. Got an input from a path in a directory and inserting the data in sheet1. I only need the defined cells in certain rows as you can see in my code. I got a predefined header for each column in sheet2 so the columns is coherent. The problem is that my r.Copy output_sheet code line gives me an error like "this action isnt available with more selections" (translated the error message from my language so dont know what exactly is written in english)

How can i fix this problem so i can make the data input, copy the specific cells and paste them in sheet2?

Sub call_copy_sub_ranges()

    Worksheets("Ark2").[A1].Value = "'headerName"
    Worksheets("Ark2").[B1].Value = "'headerName"
    Worksheets("Ark2").[C1].Value = "'headerName"
    Worksheets("Ark2").[D1].Value = "'headerName"
    Worksheets("Ark2").[E1].Value = "'headerName"
    Worksheets("Ark2").[F1].Value = "'headerName"
    Worksheets("Ark2").[G1].Value = "'headerName"
    Worksheets("Ark2").[H1].Value = "'headerName"
    Worksheets("Ark2").[I1].Value = "'headerName"
    Worksheets("Ark2").[J1].Value = "'headerName"
    Worksheets("Ark2").[K1].Value = "'headerName"
    Worksheets("Ark2").[L1].Value = "'headerName"
    Worksheets("Ark2").[M1].Value = "'headerName"
    Worksheets("Ark2").[N1].Value = "'headerName"
    Worksheets("Ark2").[O1].Value = "'headerName"
    Worksheets("Ark2").[P1].Value = "'headerName"
    Worksheets("Ark2").[Q1].Value = "'headerName"
    Worksheets("Ark2").[R1].Value = "'headerName"
    Worksheets("Ark2").[S1].Value = "'headerName"
    Worksheets("Ark2").[T1].Value = "'headerName"
    Worksheets("Ark2").[U1].Value = "'headerName"
    Worksheets("Ark2").[V1].Value = "'headerName"
    Worksheets("Ark2").[W1].Value = "'headerName"
    Worksheets("Ark2").[X1].Value = "'headerName"
    Worksheets("Ark2").[Y1].Value = "'headerName"
    Worksheets("Ark2").[Z1].Value = "'headerName"
    Worksheets("Ark2").[AA1].Value = "'headerName"
    Worksheets("Ark2").[AB1].Value = "'headerName"
    Worksheets("Ark2").[AC1].Value = "'headerName"
    Worksheets("Ark2").[AD1].Value = "'headerName"
    Worksheets("Ark2").[AE1].Value = "'headerName"
    Worksheets("Ark2").[AF1].Value = "'headerName"
    Worksheets("Ark2").[AG1].Value = "'headerName"
    Worksheets("Ark2").[AH1].Value = "'headerName"
    Worksheets("Ark2").[AI1].Value = "'headerName"
    Worksheets("Ark2").[AJ1].Value = "'headerName"
    Worksheets("Ark2").[AK1].Value = "'headerName"
    Worksheets("Ark2").[AL1].Value = "'headerName"
    Worksheets("Ark2").[AM1].Value = "'headerName"
    Worksheets("Ark2").[AN1].Value = "'headerName"
    Worksheets("Ark2").[AO1].Value = "'headerName"
    Worksheets("Ark2").[AP1].Value = "'headerName"
    Worksheets("Ark2").[AQ1].Value = "'headerName"
    Worksheets("Ark2").[AR1].Value = "'headerName"
    Worksheets("Ark2").[AS1].Value = "'headerName"
    Worksheets("Ark2").[AT1].Value = "'headerName"
    Worksheets("Ark2").[AU1].Value = "'headerName"
    Worksheets("Ark2").[AV1].Value = "'headerName"
    Worksheets("Ark2").[AW1].Value = "'headerName"
    Worksheets("Ark2").[AX1].Value = "'headerName"
    Worksheets("Ark2").[AY1].Value = "'headerName"

    Dim super_range As Range
    Set super_range = ThisWorkbook.Worksheets("Ark1").Columns("A:EI")

    Dim output_sheet As Worksheet
    Set output_sheet = ThisWorkbook.Worksheets("Ark2")

    copy_sub_ranges super_range, output_sheet

End Sub


Sub copy_sub_ranges(ByVal super_range As Range, ByVal output_sheet As Worksheet)

    Dim r As Range

    Set r = super_range.Range("S2:S3")
    Set r = Union(r, super_range.Range("BF7:BF8"))
    Set r = Union(r, super_range.Range("BG7:BG8"))
    Set r = Union(r, super_range.Range("BH7:BH8"))
    Set r = Union(r, super_range.Range("BI9:BI10"))
    Set r = Union(r, super_range.Range("BJ9:BJ10"))
    Set r = Union(r, super_range.Range("BK9:BK10"))
    Set r = Union(r, super_range.Range("BL9:BL10"))
    Set r = Union(r, super_range.Range("BM9:BM10"))
    Set r = Union(r, super_range.Range("BN9:BN10"))
    Set r = Union(r, super_range.Range("BO9:BO10"))
    Set r = Union(r, super_range.Range("BP9:BP10"))
    Set r = Union(r, super_range.Range("BQ9:BQ10"))
    Set r = Union(r, super_range.Range("BR9:BR10"))
    Set r = Union(r, super_range.Range("BS9:BR10"))
    Set r = Union(r, super_range.Range("BT9:BT10"))
    Set r = Union(r, super_range.Range("BU9:BU10"))
    Set r = Union(r, super_range.Range("BV9:BV10"))
    Set r = Union(r, super_range.Range("BW9:BW10"))
    Set r = Union(r, super_range.Range("BX9:BX10"))
    Set r = Union(r, super_range.Range("BY9:BY10"))
    Set r = Union(r, super_range.Range("BZ9:BZ10"))
    Set r = Union(r, super_range.Range("CA9:CA10"))
    Set r = Union(r, super_range.Range("CB9:CB10"))
    Set r = Union(r, super_range.Range("CC9:CC10"))
    Set r = Union(r, super_range.Range("CD9:CD9"))
    Set r = Union(r, super_range.Range("CE9:CE9"))
    Set r = Union(r, super_range.Range("CF9:CF9"))
    Set r = Union(r, super_range.Range("CG9:CG9"))
    Set r = Union(r, super_range.Range("CH9:CH9"))
    Set r = Union(r, super_range.Range("CI9:CI9"))
    Set r = Union(r, super_range.Range("CJ9:CJ9"))
    Set r = Union(r, super_range.Range("CK9:CK9"))
    Set r = Union(r, super_range.Range("CL9:CL9"))
    Set r = Union(r, super_range.Range("CM9:CM9"))
    Set r = Union(r, super_range.Range("CN9:CN9"))
    Set r = Union(r, super_range.Range("CO9:CO9"))
    Set r = Union(r, super_range.Range("CP9:CP9"))
    Set r = Union(r, super_range.Range("CQ9:CQ9"))
    Set r = Union(r, super_range.Range("CR9:CR10"))
    Set r = Union(r, super_range.Range("CS9:CS10"))
    Set r = Union(r, super_range.Range("CT9:CT9"))
    Set r = Union(r, super_range.Range("CU9:CU9"))
    Set r = Union(r, super_range.Range("CV9:CV9"))
    Set r = Union(r, super_range.Range("CW9:CW10"))
    Set r = Union(r, super_range.Range("CX10:CX10"))
    Set r = Union(r, super_range.Range("EE9:EE10"))
    Set r = Union(r, super_range.Range("EF9:EF10"))
    Set r = Union(r, super_range.Range("EG9:EG10"))
    Set r = Union(r, super_range.Range("EH9:EH10"))
    Set r = Union(r, super_range.Range("EI9:EI10"))

    Dim offset As Long
    If IsEmpty(output_sheet.Range("A1").Text) Then offset = 0 Else offset = 1

    r.Copy output_sheet.Cells(output_sheet.Cells.Rows.Count, 1).End(xlUp).offset(offset, 0)

End Sub

You can reference multiple ranges from a single call to the Range method: Set r = super_range.Range("S2:S3,BF7:BF8") etc. You can also set the same value on multiple cells in the range: `Worksheets("Ark2").Range("A1,B1").Value = "headerName". — user20416
– user20416, Commented Feb 23, 2021 at 12:32
For reference, the error in English is That command cannot be used on multiple selections. I guess the only way to work around this is to write a new Sub that iterates over the subranges in the Range.Areas property, and copy each one individually relative to the destination range. — user20416
– user20416, Commented Feb 23, 2021 at 12:38
Thank you so much for the help, were a bit stuck, so I'm very happy for the help:) — user14345147
– user14345147, Commented Feb 24, 2021 at 10:16

user20416 · Accepted Answer · 2021-02-25 09:30:52Z

1

AFAICT the problem is Excel doesn't support copying/pasting from a range that has multiple areas, like this:

Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Ark1").Range( _
    "S2:S3," & _
    "BF7:BH8," & _
    "BI9:CC10," & _
    "CD9:CQ9," & _
    "CR9:CS10," & _
    "CT9:CV9," & _
    "CW9:CX10," & _
    "EE9:EI10" _
)

We can get each of the subranges from the Areas property:

Dim subrange As Range
For Each subrange In rng.Areas
    Debug.Print subrange.Address
Next

So we can write a method that:

if there is only one area in the range, it will copy the entire range to the destination
if there is more than one area, it will copy each area individually to the destination; not directly to the destination, but offset the same number of rows and columns from the destination as the area is from the worksheet.

Sub CopyMultiRange(src As Range, dest As Range)
If src.Areas.Count = 1 Then
    src.Copy dest
    Exit Sub
End If

Dim subrange As Range
For Each subrange In src.Areas
    CopyMultiRange subrange, dest.Offset(subrange.Row - 1, subrange.Column - 1)
Next
End Sub

And you can call it like this:

CopyMultiRange rng, Worksheets("Ark2").Range("A1")

Notes:

Ideally we'd want to copy each subrange to the destination relative to the offset the subrange is from the source range. However, I didn't find any way to get the minimum top/left corner of all the subranges. So the offset is calculated off the worksheet, using the Row and Column properties.
To account for the possibility that a range might have multiple levels of subranges, the method calls itself. I haven't checked that this can actually happen.

edited Feb 25, 2021 at 9:30

answered Feb 24, 2021 at 12:38

user20416

15.5k9 gold badges76 silver badges149 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

CDP1802 Over a year ago

Note this copies for example cell S2 to cell T3 on Ark2 but I read the requirement as aligning the copied ranges into 2 rows under the heading col A to AY1. so S to A, BF to B etc

user14345147 Over a year ago

@CDP1802 when i make a macro button by going to developer and making it manually, it disappear when i make a new data input in sheet1, why is that?

CDP1802 · Accepted Answer · 2021-02-24 11:36:05Z

0

As Zev said, copy each range individually

Option Explicit

Sub call_copy_sub_ranges()

    Dim ws1 As Worksheet, wsOut As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Ark1")
    Set wsOut = ThisWorkbook.Worksheets("Ark2")

    Dim ar
    ar = Array("HeaderA", "HeaderB", "HeaderC", "HeaderD", "HeaderE", _
    "HeaderF", "HeaderG", "HeaderH", "HeaderI", "HeaderJ", "HeaderK", _
    "HeaderL", "HeaderM", "HeaderN", "HeaderO", "HeaderP", "HeaderQ", _
    "HeaderR", "HeaderS", "HeaderT", "HeaderU", "HeaderV", "HeaderW", _
    "HeaderX", "HeaderY", "HeaderZ", "HeaderAA", "HeaderAB", "HeaderAC", _
    "HeaderAD", "HeaderAE", "HeaderAF", "HeaderAG", "HeaderAH", "HeaderAI", _
    "HeaderAJ", "HeaderAK", "HeaderAL", "HeaderAM", "HeaderAN", "HeaderAO", _
    "HeaderAP", "HeaderAQ", "HeaderAR", "HeaderAS", "HeaderAT", "HeaderAU", _
    "HeaderAV", "HeaderAW", "HeaderAX", "HeaderAY")
       
    wsOut.Range("A1:AY1").Value = ar
    copy_sub_ranges ws1, wsOut
    MsgBox "Done"

End Sub


Sub copy_sub_ranges(ByVal ws1 As Worksheet, ByVal wsOut As Worksheet)

    Dim rng As Range, rngOut As Range, ar, s
    ar = Array("S2:S3", "BF7:BH8", "BI9:CC10", _
                "CD9:CQ9", "CR9:CS10", "CT9:CV9", "CW9:CW10", "CX10", "EE9:EI10")
                   
    ' target
    Set rngOut = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
    If Not IsEmpty(wsOut.Range("A1").Text) Then
       Set rngOut = rngOut.offset(1, 0)
    End If
    
    For Each s In ar
       Set rng = ws1.Range(s)
       Debug.Print rng.Address, rngOut.Address
       
       rng.Copy rngOut
       Set rngOut = rngOut.offset(0, rng.Columns.Count)
    Next

    ' underline
    Set rng = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
    With rng.Resize(1, rngOut.Column - 1).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .Weight = xlMedium
    End With

End Sub

edited Feb 24, 2021 at 11:36

answered Feb 23, 2021 at 14:13

CDP1802

17.3k2 gold badges10 silver badges19 bronze badges

12 Comments

user14345147 Over a year ago

Thank you so much! I works so perfect. How can i auto adjust alle the headers and data which gets pasted in sheet2? Some of the cells has "#####" as there isnt enough space

CDP1802 Over a year ago

@Anonymous Add wsOut.Columns("A:AY").AutoFit at the end (before msgbox "Done")

user14345147 Over a year ago

You have made my day! Thanks for the help, im a rookie to VBA. Have a great day:)

user20416 Over a year ago

This isn't quite what I was suggesting, nor does it actually answer the problem, because you're creating the ranges as single-area ranges based on the array, not using a multi-area array as in the question. The Range object exposes an Areas property, which returns the subranges of a specified Range object; you could iterate over Areas, calculate the offset of each subrange from the original range, and paste the subrange onto the destination range with the same offset.

user14345147 Over a year ago

Is it possible to code a Macro button in sheet1 so i just need to click instead of press F5. Or should i just go to developer in the menu line and make one myself? If the macro button isnt made in the code, then how can it stay in sheet1 when i make a new data input? Hope you can understand the question:) TIA

|

Collectives™ on Stack Overflow

VBA: error message in r.Copy output_sheet

2 Answers 2

2 Comments

12 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

12 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related