Question

我有两个工作表。 L12 Database和Working Sheet。我有一个userform，它将任何工作表中的数据行复制到工作表的范围A393。但是我意识到我只需要复制该行的某些列数据而不是整行。它分为3个范围，L12 Database should copy Columns A:D, I:J, and L:R.此复制的数据应paste Working Sheet Columns A: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

在用户表单中复制粘贴三个不同的范围

1 个答案: