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

我有两个工作表。 L12 Database和Working Sheet 。 我有一个用户A393 ，从任何工作表的范围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 。 以前的build议是做一个循环，但它只适用于两个范围。 因此，我需要一些帮助，我可以复制和粘贴到一个用户窗体中的三个范围。 这是一个由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

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

我会抛出两个解决scheme

---

解答A

遵循你的“scheme”

 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 

---

解决schemeB

我明白，只要用户在工作表中select一个单元格，然后就可以从该单元格行中的相关列中复制单元格，并将它们粘贴到从相应单元格地址开始的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 

---

当然，这两种解决scheme还是可以优化的，例如：

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

  这样做，每个“对”都有一个循环处理。 所以万一你的需求会再次改变（而且很可能他们会…）你只需要添加元素到数组，而不改变代码

• 添加RefEdit返回文本validation

  这个控件接受从用户input的任何东西 ，所以你可能想添加一个检查，它真的返回一个有效的范围

  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