VBA 根据单元格的内部颜色在 2 行之间复制

Question

I have an excel file, where I need to copy-paste rows, starting from row 3. If cell in column C is grey (RGB: 191,191,191) to copy paste untill nexy grey row.

Below you can see what I achieved so far. But I do something wrong I think.. So when I check

• rownum = 12 ( which is correct, row 13 is where first grey cell is )
• lastrow = 172 ( also correct )
• startrow = here is problem I think, it is always 0, I don't know why.

Any help if possible will be appreciated. thanks in advance..

   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 3
   colnum = 3
   lastrow = ActiveSheet.Range("C65536").End(xlUp).Row
   With ActiveSheet.Range("C3:C" & lastrow)


   For rownum = 3 To lastrow
    Do
       If .Cells(rownum, 3).Interior.Color = RGB(191, 191, 191) Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 3).Interior.Color = RGB(191, 191, 191)
   endrow = rownum
   rownum = rownum + 1

   ActiveSheet.Range(Cells(startrow, 2), Cells(endrow, 17)).Copy

   'Sheets("Result").Select
   'Range("A1").Select
   'Sheets("Result").PasteSpecial xlPasteValuesAndNumberFormats


   Next rownum
   End With
   End Sub ``` 

Answer 1

Copy Between Colored Cells

Sub CopyBetweenColoredCells()
    
    ' Define constants.
    
    ' Source
    Const sfRow As Long = 3
    Const sCols As String = "B:Q"
    Const scIndex As Long = 2
    Dim sColor As Long: sColor = RGB(191, 191, 191)
    ' Destination
    Const dName As String = "Result"
    Const dFirstCellAddress As String = "A2"
        
    ' Reference the workbook ('wb').
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range ('srg').
    
    Dim sws As Worksheet: Set sws = wb.ActiveSheet ' adjust!
    Dim srCount As Long
    With sws.UsedRange
        srCount = .Rows.Count + .Row - sfRow
        If srCount < 1 Then
            MsgBox "No data.", vbCritical
            Exit Sub
        End If
    End With
    Dim srg As Range: Set srg = sws.Rows(sfRow).Columns(sCols).Resize(srCount)
         
    ' Using the 'RefBetweenColoredCells' function,
    ' reference the source copy range ('scrg').
    
    Dim scrg As Range: Set scrg = RefBetweenColoredCells(srg, scIndex, sColor)
    
    If scrg Is Nothing Then
        MsgBox "No range found.", vbExclamation
        Exit Sub
    End If
    
    ' Reference the first destination cell ('dfCell').
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    
    ' Copy.
    
    scrg.Copy
    'dfCell.PasteSpecial xlPasteColumnWidths
    dfCell.PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    'wb.Save
    
    ' Inform.
    
    MsgBox "Data copied.", vbInformation
 
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a column ('SourceColorColumnIndex') of a range
'               ('SourceRange'), after identifying cell pairs
'               that are highlighted in a color ('SourceColor'), refences
'               the range rows between the cell pairs inclusive.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefBetweenColoredCells( _
    ByVal SourceRange As Range, _
    ByVal SourceColorColumnIndex As Long, _
    ByVal SourceColor As Long) _
As Range
    
    Dim urg As Range
    Dim rg As Range
    Dim cell As Range
    Dim r As Long
    Dim rStart As Long
    
    For Each cell In SourceRange.Columns(SourceColorColumnIndex).Cells
        r = r + 1
        If cell.Interior.Color = SourceColor Then
            If rStart = 0 Then
                rStart = r
            Else
                Set rg = SourceRange.Rows(rStart).Resize(r - rStart + 1)
                rStart = 0
                If urg Is Nothing Then ' first range
                    Set urg = rg
                Else ' all but the first range
                    Set urg = Union(urg, rg)
                End If
            End If
        End If
    Next cell
            
    If Not urg Is Nothing Then Set RefBetweenColoredCells = urg
            
End Function