在用户窗体中复制粘贴三个不同的范围

Question

我有两个工作表。 L12 Database 和 Working Sheet。我有一个用户表单，它可以将任何工作表中的数据行复制到工作表的A393 范围内。但是我意识到我只需要复制该行的某些列数据而不是整行。它分为3个范围​​，L12 Database should copyColumns A:D, I:J, and L:R.这个复制的数据应该paste进入Working SheetColumnsA:D,E:F and I:O。以前的建议是循环，但它只适用于两个范围。因此，我需要一些关于如何在一个用户表单中复制和粘贴到三个范围的帮助。这是由 stackoverflow 用户完成的代码（对不起，我不记得你的名字），这是我大致想要做的。谢谢！

Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim LngCounter As Long

If RefEdit1.Value <> "" Then
    Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
    Set wsPaste = ThisWorkbook.Sheets("Working Sheet")
    For LngCounter = 0 To 1
        If LngCounter = 0 Then
            Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
            Set rngPaste = wsPaste.Range("A401")
        Else
            Set rngCopy = wsCopy.Range(Replace(Replace(Split(RefEdit1.Value, "!")(1), "A", "I"), "D", "R"))
            Set rngPaste = wsPaste.Range("E401")
        End If

        If CheckBox1.Value = True Then
            wsPaste.Activate
            rngPaste.Select
            rngCopy.Copy
            ActiveSheet.Paste Link:=True
        Else
            rngCopy.Copy rngPaste
        End If

        Set rngPaste = Nothing
        Set rngCopy = Nothing

    Next
Else
    MsgBox "Please select Input range"
End If
End Sub

这是我之前做的用户表单代码：

Private Sub CommandButton1_Click()
    Dim rngCopy As Range, rngPaste As Range
    Dim wsCopy As Worksheet, wsPaste As Worksheet

    If RefEdit1.Value <> "" Then
        Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", "")) 'Sheet name of the data selected by user
        Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1)) 'Range of the data selected by user

        Set wsPaste = ThisWorkbook.Sheets("Working Sheet") 'Sheet location where data copied would be pasted
        Set rngPaste = wsPaste.Range("A393") 'Range Area where data copied would be pasted in columns A and B of database sheet

        If CheckBox1.Value = True Then
            wsPaste.Activate
            rngPaste.Select
            rngCopy.Copy
            ActiveSheet.Paste Link:=True 'Activate paste link between info sheet and database sheet
        Else
            rngCopy.Copy rngPaste
        End If
    Else
        MsgBox "Please select Input range" 'If user did not key in any input, this message wouldp pop up
    End If
End Sub   

Answer 1

已编辑：修复“解决方案 A”区域对象处理。并添加了“rngPaste 处理

我将提出两种解决方案

---

解决方案 A

按照你的“计划”

Option Explicit

Private Sub CommandButton1_Click()
    Dim rngCopy As Range, rngPaste As Range, rngSelected As Areas '<~~ rngSelected is to be of "Areas" type
    Dim wsCopy As Worksheet, wsPaste As Worksheet, wsActive As Worksheet

    If RefEdit1.Value <> "" Then

        Set rngSelected = Range(Replace(RefEdit1.Text, ";", ",")).Areas  '<~~ store the selected range. Note:I had to use this Rpelace since my country customizations has addresses returned by RefEdit control Text property separed by a ";" instead of a ","
        Set wsCopy = rngSelected.Parent.Parent '<~~ the parent property of Areas object returns a Range object, whose parent property eventually returns a worksheet object!
        Set wsPaste = ThisWorkbook.Sheets("Working Sheet")

        If Me.CheckBox1 Then '<~~ if requested...
            Set wsActive = ActiveSheet ''<~~ ... store active sheet for eventually returning to it...
            wsPaste.Select ''<~~  ... and activate "wsPaste" sheet once for all and avoid sheets jumping
        End If

        For Each rngCopy In rngSelected
            Set rngPaste = Nothing '<~~ initialize rngPaste to Nothing, so that it's possible to detect its possible setting to a range if any check of Select Case block is successful
            Select Case rngCopy.Columns.EntireColumn.Address(False, False) '<~~ check columns involved in each area
                Case "A:D" '<~~ if columns range A to D is involved, then...
                    Set rngPaste = wsPaste.Range("A401") '<~~ ... have it pasted form wsPaste cell A401 on
                Case "I:J" '<~~ if columns range I to J is involved, then...
                    Set rngPaste = wsPaste.Range("E401") '<~~ ... have it pasted form wsPaste cell E401 on
                Case "L:R" '<~~ if columns range L to R is involved, then...
                   Set rngPaste = wsPaste.Range("I401") '<~~ ... have it pasted form wsPaste cell I401 on
            End Select

            If Not rngPaste Is Nothing Then '<~~ check to see if any rngPaste has been set
                If Me.CheckBox1.Value Then
                    rngPaste.Select
                    rngCopy.Copy
                    ActiveSheet.Paste link:=True
                Else
                    rngCopy.Copy rngPaste
                End If
            End If

        Next rngCopy

        If Me.CheckBox1 Then
            wsActive.Select '<~~ if necessary, return to starting active sheet
        End If

    Else
        MsgBox "Please select Input range"
    End If
End Sub

---

解决方案 B

我理解它只需要用户选择工作表中的单个单元格，然后您将从该单元格行中的相关列复制单元格并将它们从相应的单元格地址开始粘贴到 wsPaste 工作表中：

Private Sub CommandButton1_Click()
    Dim rngSelected As Range, rngCopy As Range
    Dim wsCopy As Worksheet, wsPaste As Worksheet, wsActive As Worksheet

    If RefEdit1.Value <> "" Then

        Set rngSelected = Range(Replace(RefEdit1.Text, ";", ",")).Areas(1).Cells(1, 1).EntireRow '<~~ store the selected range. Note:I had to use this Replace since my country customization has addresses returned by RefEdit control Text property separated by a ";" instead of a ","
        Set wsCopy = rngSelected.Parent
        Set wsPaste = ThisWorkbook.Sheets("Working Sheet")

        If Me.CheckBox1 Then '<~~ if requested...
            Set wsActive = ActiveSheet ''<~~ ... store active sheet for eventually returning to it...
            wsPaste.Select ''<~~  ... and activate "wsPaste" sheet once for all and avoid sheets jumping
        End If

        Set rngCopy = Intersect(rngSelected, wsCopy.Columns("A:D"))
        If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("A401"), Me.CheckBox1

        Set rngCopy = Intersect(rngSelected, wsCopy.Columns("I:J"))
        If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("E401"), Me.CheckBox1

        Set rngCopy = Intersect(rngSelected, wsCopy.Columns("L:R"))
        If Not rngCopy Is Nothing Then copyrng rngCopy, wsPaste.Range("I401"), Me.CheckBox1

        If Me.CheckBox1 Then
            wsActive.Select '<~~ if necessary, return to starting active sheet
        End If

    Else
        MsgBox "Please select Input range"
    End If

End Sub

Sub copyrng(rngCopy As Range, rngPaste As Range, okLink As Boolean)
    If Not rngCopy Is Nothing Then
        If okLink Then
            rngPaste.Select
            rngCopy.Copy
            ActiveSheet.Paste link:=True
        Else
            rngCopy.Copy rngPaste
        End If
    End If
End Sub

---

当然，这两种解决方案仍然可以优化，例如：

• 将复制列和相应的粘贴单元格存储到数组中

  这个，有一个循环处理每个“对”。这样万一你的需求会再次改变（很可能他们会......）你只需要在不改变代码的情况下向数组中添加元素

• 添加 RefEdit 返回文本验证

  此控件接受用户输入的任何内容 所以你可能想要添加一个检查它是否真的返回了一个有效的范围 像

  If Not Range(RefEdit1.Text) Is Nothing Then... '<~~ if you expect only one selection

  或

  If Not Range(Range(Replace(RefEdit1.Text, ";", ",")).Areas) Is Nothing Then... '<~~ if you expect more then one selection