Is it possible to paste into a range created by a Union in vba?-CodePudding

I have several rows where after the 6th column, the first few cells have a specific color. How many cells in each row have this color is not consistent. As part of a larger macro, I need to seperate these first few colored cells of each row, from the non-colored ones, and put them in two seperate rows in a different sheet. So I made the following Macro.

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

When I run this macro I get a run-time error 1004 on the following line:

G_Req.Copy Destination:=I_Empty1

I believe that I'm doing something wrong in my usage of Union, or in how I defined the I_Empty1, but I'm not sure what. Could someone help me?

CodePudding user response：

Export Data By Color

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

CodePudding user response：

So thanks to the advice given, I tried some things, and the following does exactly what I want it to do.

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

Argueably, the If Not G_Cell Is Nothing Then statements are probably not necessary, but It doesn't look like it's causing trouble either.