How to copy specific rows to another sheet below black cell-CodePudding

I want to write a macro to copy rows from one worksheet to another below cell that is colored black (manually) - if it is detected, otherwise just copy rows from first sheet to Sheet1 at the top. After many trials and errors I came up with that code:

Sub copytherows(clf As Long, lastcell As Long) 'clf - cell that marks the start, lastcell - ending cell
   
    Dim st As Long, cnext As Range
    Dim wshet As Worksheet
    Dim wshetend As Worksheet
    'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
    Set wshet = Worksheets(1)
    Set wshetend = Sheets("Sheet1")
    wshetend.Cells.Delete
    
    For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
        If wshet.Cells(st, "B").Interior.Color = clf Then 'has the color of interest
             cnextcoprow = st
            Set cnext = wshet.Cells(st, "B").Offset(1, 0)            'next cell down
            
            Do While cnext.Interior.Color <> lastcell
                Set cnext = cnext.Offset(1, 0) 'next row
            Loop
            st = st   1
            
        End If
    Next st
  cnextrow = cnext.Row - 1
  
    coprange = cnextcoprow & ":" & cnextrow

Aend = Cells(Rows.Count, "A").End(xlUp).Row
'set color is black
  TargetColor = RGB(255, 255, 255)


wshetend.Activate

  For x = 1 To Rows.Count
    If wshetend.Cells(x, "A").Interior.Color = TargetColor Then

      
      x = x   1
       Set rangehelper = wshetend.Rows(x)
      wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
     
 Else
 wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
 End If
 Next x
End Sub

When Macro is ran it displays an error(Run-time error '1004' Method 'Range' of object '_Worksheet' failed on line :

wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)

Sheet1 is for sure present in Workbook. Edit as suggested by @FaneDuru: 1 - in this image is my curret state of worksheet that is wshet in my macro and for example if I select (by checkboxes) section1 and section3, section3 should be in the place of black cell in section1 (the order of sections doesn't really matter to me) inside destination sheet ( I know I'm not good in explaining things like that).
2 - this should be end result of this macro

CodePudding user response：

It's quite confusing how you use the for loops. In the first one you use it to check for the start -which is fine- but then you put a while loop in there which will end up in an endless loop once your st gets past your lastcell row, instead use

    ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
        cnextrow = st
        Exit For
    End If

In the second for loop you copy the rows if you find the black cell but you don't exit the for loop, speaking of which, you delete all the cells in your wshetend so you'll always start at row 1. So either you don't want to delete all the cells in your wshetend or the for loop is unnecessary.

This is my testSub and it copies from the first sheet to Sheet2 after the cell with black background (black = 0) (commented out the delete cells)

Sub TestBlackCellCopy()
    Dim st As Long, cnext As Range
    Dim wshet As Worksheet
    Dim wshetend As Worksheet
    'st - start of looking up, cnext - range of lines, wshet - worksheet
    Dim coprange As String
    Dim cnextcoprow, cnextrow As Long
    'variables for copying macro part
    Dim rangehelper As Range
    Dim TargetColor As Long
    Dim cell As Range
    Dim sht As Worksheet
    Dim x As Long
    Dim Aend As Long
    Dim clf As Long, lastcell As Long
    clf = 5296274
    lastcell = 65535
    cnextcoprow = 0
    
    Set wshet = Worksheets(1)
    Set wshetend = Sheets("Sheet1")
'    wshetend.Cells.Delete
    
    For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
        Debug.Print (wshet.Cells(st, "B").Interior.Color)
        If wshet.Cells(st, "B").Interior.Color = clf And cnextcoprow = 0 Then 'has the color of interest
             cnextcoprow = st
        ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
            cnextrow = st - 1
            Exit For
        End If
    Next st

    coprange = cnextcoprow & ":" & cnextrow

    Aend = Cells(Rows.Count, "A").End(xlUp).Row 'unused variable?
    'set color is black
    TargetColor = 0


    wshetend.Activate
    
    For x = 1 To Rows.Count
        Debug.Print (wshetend.Cells(x, "A").Interior.Color)
        If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
          wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
          Exit For
'        Else
'            wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next x
End Sub

So you'll have to figure out what exactly you want, to delete the cells? Then it starts at row 1, then put a skip after a copy you place after the second for loop. Something like this:

wshetend.Activate
    
    Aend = Cells(Rows.Count, "A").End(xlUp).Row
    For x = 1 To Rows.Count
        Debug.Print (wshetend.Cells(x, "A").Interior.Color)
        If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
          wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
          GoTo skipFor
        End If
    Next x
    wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A1")
skipFor:

Hope this helps.

CodePudding user response：

Please, try the next way. It should work if you respected all what we set in the above discussion (check boxes in G:G, black cells in B:B for first sheet, and a black cell in any place of the second sheet:

Sub CopyRowsCheckBox_Black_limited()
   Dim wshet As Worksheet, wshetend As Worksheet, blackCell As Range, redCell As Range, rngCopy As Range
   Dim sh As Shape, chkB As MSForms.CheckBox, cellPaste As Range, pasteRow As Long
   
   Set wshet = ActiveSheet       'use here the sheet where from you need copying
   Set wshetend = wshet.Next  'use here the sheet where to copy
   
   'settings to make Find function searching for Interior color:
   With Application.FindFormat
        .Clear: .Interior.Color = vbBlack
        .Locked = True
  End With
  
  'find the black cell in the second sheet:
  Set cellPaste = wshetend.cells.Find(What:=vbNullString, After:=wshetend.Range("A1"), SearchFormat:=True)
  If Not cellPaste Is Nothing Then  'set the row where to copy first
        pasteRow = cellPaste.Offset(1).row
  Else
        pasteRow = 1
  End If
  
  'iterate between all shapes, found the ones being checkBoxes and being on column G:G, set the rows range and copy it:
   For Each sh In wshet.Shapes
        If TypeName(sh.OLEFormat.Object.Object) = "CheckBox" And sh.TopLeftCell.Column = 7 Then
            Set chkB = sh.OLEFormat.Object.Object 'set the checkBox ActiveX object
            If chkB.Value = True Then                          'if it is checked
                 Set blackCell = wshet.Range("B:B").Find(What:=vbNullString, After:=wshet.Range("B" & _
                                                                                                   sh.TopLeftCell.row), SearchFormat:=True) 'find first black cell
                      Set rngCopy = wshet.Range(wshet.Range("B" & sh.TopLeftCell.row), blackCell).EntireRow 'set the rows to be copied
                      rngCopy.Copy wshetend.Range("A" & pasteRow): pasteRow = pasteRow   rngCopy.rows.count 'copy and update pasting row
            End If
        End If
  Next sh
  
   MsgBox "Ready..."
End Sub

The range to be copied is the one between the checked check box and the first black cell in B:B column.

Important Note: The top left corner of the check boxes must be inside of first series row!

Please, send some feedback after testing it.