文章/答案/技术大牛

发布

社区首页 >问答首页 >VBA: r.Copy output_sheet中的错误消息

问VBA: r.Copy output_sheet中的错误消息
EN

Stack Overflow用户

提问于 2021-02-23 18:45:00

回答 2查看 63关注 0票数 0

在尝试将数据从sheet1复制到sheet2时，我遇到了问题。从目录中的路径获取输入并将数据插入到sheet1中。我只需要在某些行中定义的单元格，正如您在我的代码中所看到的那样。我为sheet2中的每一列都有一个预定义的标题，因此这些列是一致的。问题是我的r.Copy output_sheet代码行给我一个错误，如“此操作不能用于更多选择”(将错误消息从我的语言翻译过来，所以不知道到底是用英语写的)

我如何解决这个问题，以便我可以进行数据输入，复制特定的单元格，并将它们粘贴到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

excel

vba

excel-formula

回答 2

Stack Overflow用户

发布于 2021-02-24 20:38:50

AFAICT问题是Excel不支持从具有多个区域的区域中复制/粘贴，如下所示：

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" _
)

我们可以从Areas属性中获取每个子范围：

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

所以我们可以写一个方法：

如果区域中只有一个区域，它会将整个区域复制到目标
如果有多个区域，它会将每个区域单独复制到目标；不是直接复制到目标，而是从目标偏移与工作表相同的行数和列数。

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

你可以这样叫它：

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

备注：

理想情况下，我们希望将每个子范围复制到目标位置，相对于该子范围相对于源范围的偏移量。，，

。然而，我没有找到任何方法来获得所有子区域的最小左上角。因此，使用Row和Column properties.
To帐户计算工作表外的偏移量，以考虑范围可能具有多级子范围的可能性，该方法调用自身。我还没有确认这是否真的会发生。

票数 1

Stack Overflow用户

发布于 2021-02-23 22:13:42

正如Zev所说，分别复制每个范围

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

票数 0

页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://stackoverflow.com/questions/66331620

复制

相似问题

问VBA: r.Copy output_sheet中的错误消息
EN

回答 2

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问VBA: r.Copy output_sheet中的错误消息EN

回答 2

Stack Overflow用户

Stack Overflow用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问VBA: r.Copy output_sheet中的错误消息
EN