是否可以粘贴到vba中由Union创建的范围?

Question

我有几行，在第6列之后，前几个单元格具有特定的颜色。每行中有多少单元格具有这种颜色是不一致的。作为更大宏的一部分，我需要将每行的前几个彩色单元格与非彩色单元格分开，并将它们放在不同工作表中的两个单独的行中。因此，我创建了以下宏:

Dim G_Each As Range
Dim G_Range As Range
Dim G_Res_A As Range
Dim G_ws As Worksheet
Dim I_ws As Worksheet
Dim G_Res_Ra As Range
Dim G_cell As Range
Dim G_Req As Range
Dim G_Add As Range
Dim I_Empty1 As Range
Dim I_Empty2 As Range
Set G_ws = Worksheets("Groepen")
Set I_ws = Worksheets("Invoer")
Set G_Range = G_ws.Range("A2", G_ws.Range("A2").End(xlDown))
For Each G_Each in G_Range
Set G_Res_A = G_Each.Offset(0, 7)
Set G_Res_Ra = Range(G_Res_A, G_Res_A.End(xlToRight))

If I_ws.Range("F2") = "" Then
Set I_Empty1 = I_ws.Range("F2")
Else
Set I_Empty1 = I_ws.Range("F2").End(xlToRight).Offset(0, 1)
End If

If I_ws.Range("G3") = "" Then
Set I_Empty2 = I_ws.Range("G3")
Else
Set I_Empty2 = I_ws.Range("G3").End(xlToRight).Offset(0, 1)
End If

For Each G_cell In G_Res_Ra
If G_cell.Interior.Color = RGB(255, 217, 102) Then
If Not G_Req Is Nothing Then
Set G_Req = Union(G_Req, G_cell)
Else
Set G_Req = G_cell
End If
Else
If Not G_Add Is Nothing Then
Set G_Add = Union(G_Add, G_cell)
Else
Set G_Add = G_cell
End If
End If
Next G_cell

G_Req.Copy Destination:=I_Empty1
G_Add.Copy Destination:=I_Empty2
Next G_Each

当我运行这个宏时，我在下面一行得到一个运行时错误1004:

G_Req.Copy Destination:=I_Empty1

我相信我在使用Union或定义I_Empty1时做错了什么，但我不确定是什么。有人能帮帮我吗?

Answer 1

按颜色导出数据

Option Explicit
Sub ExportDataByColor()

Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

' Source

Dim sws As Worksheet: Set sws = wb.Worksheets("Groepen")
' Source Last Row
Dim slRow As Long: slRow = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
' Source Last-Row-Column Range
Dim slrcrg As Range: Set slrcrg = sws.Range("A2:A" & slRow)
' Source Column Range
Dim scrg As Range: Set scrg = slrcrg.EntireRow.Columns("H")

' Destination

Dim dws As Worksheet: Set dws = wb.Worksheets("Invoer")

' Why not "G2" or...
Dim dReqFirstCell As Range: Set dReqFirstCell = dws.Range("F2")
Dim dReqLastColumnCell As Range
Set dReqLastColumnCell = dws.Cells(2, dws.Columns.Count)
' ... why not "F3"?
Dim dAddFirstCell As Range: Set dAddFirstCell = dws.Range("G3")
Dim dAddLastColumnCell As Range
Set dAddLastColumnCell = dws.Cells(3, dws.Columns.Count)

' If you use it in the main procedure, remove it from this one.
Application.ScreenUpdating = False

dws.Range(dReqFirstCell, dReqLastColumnCell).Clear
dws.Range(dAddFirstCell, dAddLastColumnCell).Clear

' Loop

Dim scCell As Range ' Source Column Cell
Dim srrg As Range ' Source Row Range
Dim slcCell As Range ' Source Last Column Cell
Dim srCell As Range ' Source Row Cell
Dim srgReq As Range
Dim srgAdd As Range

For Each scCell In scrg.Cells

' Source
Set slcCell = sws.Cells(scCell.Row, sws.Columns.Count).End(xlToLeft)
Set srrg = sws.Range(scCell, slcCell)
For Each srCell In srrg.Cells
If srCell.Interior.Color = RGB(255, 217, 102) Then ' 6740479
Set srgReq = GetCombinedRange(srgReq, srCell)
Else
Set srgAdd = GetCombinedRange(srgAdd, srCell)
End If
Next srCell

' Copy and reset.
If Not srgReq Is Nothing Then
srgReq.Copy Destination:=dReqFirstCell
Set dReqFirstCell = dReqFirstCell.Offset(, srgReq.Cells.Count)
Set srgReq = Nothing
End If
If Not srgAdd Is Nothing Then
srgAdd.Copy Destination:=dAddFirstCell
Set dAddFirstCell = dAddFirstCell.Offset(, srgAdd.Cells.Count)
Set srgAdd = Nothing
End If

Next scCell
' If you use it in the main procedure, remove it from this one.
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
' Remarks:      An error will occur if 'AddRange' is 'Nothing'
'               or if the ranges are in different worksheets.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set GetCombinedRange = AddRange
Else
Set GetCombinedRange = Union(CombinedRange, AddRange)
End If
End Function

Answer 2

因此，由于给出的建议，我尝试了一些东西，下面的内容正是我想要的。

Dim G_Each As Range
Dim G_Range As Range
Dim G_Res_A As Range
Dim G_ws As Worksheet
Dim I_ws As Worksheet
Dim G_Res_Ra As Range
Dim G_cell As Range
Dim G_Req As Range
Dim G_Add As Range
Dim I_Empty1 As Range
Dim I_Empty2 As Range
Set G_ws = Worksheets("Groepen")
Set I_ws = Worksheets("Invoer")
Set G_Range = G_ws.Range("A2", G_ws.Range("A2").End(xlDown))
For Each G_Each in G_Range
Set G_Res_A = G_Each.Offset(0, 7)
Set G_Res_Ra = Range(G_Res_A, G_Res_A.End(xlToRight))

For Each G_cell In G_Res_Ra
If G_cell.Interior.Color = RGB(255, 217, 102) Then
If I_ws.Range("F2") = "" Then
Set I_Empty1 = I_ws.Range("F2")
ElseIf I_ws.Range("F2").Offset(0, 1) = "" Then
Set I_Empty1 = I_ws.Range("G2")
Else
Set I_Empty1 = I_ws.Range("F2").End(xlToRight).Offset(0, 1)
End If
If Not G_cell Is Nothing Then
G_cell.Copy Destination:=I_Empty1
End If
Else
If I_ws.Range("G3") = "" Then
Set I_Empty2 = I_ws.Range("G3")
ElseIf I_ws.Range("G3").Offset(0, 1) = "" Then
Set I_Empty2 = I_ws.Range("H3")
Else
Set I_Empty2 = I_ws.Range("G3").End(xlToRight).Offset(0, 1)
End If

If Not G_cell Is Nothing Then
G_cell.Copy Destination:=I_Empty2
End If
End If
Next G_cell
Next G_Each

有争议的是，If Not G_Cell Is Nothing Then语句可能不是必需的，但它看起来也没有引起麻烦。