Copy Rows If Relative Checkboxes Are Checked - VBA

[Storm08]

Hi All!

I'm looking for some VBA code that fulfils the following:

On Sheet1, each row has a check box in Column A. If a checkbox is checked from Column A, it's corresponding Row copied to Sheet2 when a button is pressed.

The other Columns on Sheet1 do not have check boxes in them, only certain columns (B, C, F, G, O, P) are to be copied to Sheet2 when the button is pressed.

When copying to Sheet2, the gaps in-between the Columns should be deleted.

Thanks in advance,

Joe

EDIT: I have tried using code from previous threads, but cant seem to make it work!

[Storm08]

I have got this piece of code:

Sub Update_Click()
  For Each tb In Sheet1.CheckBoxes
   With tb.TopLeftCell
     If tb = 1 Then
        If .Column = 1 Then Sheets("sheet2").Rows(.Row) = Rows(.Row).Formula
        If .Row = 1 Then Sheets("sheet2").Columns(.Column) = Columns(.Column).Formula
     Else
        If .Row = 1 Then Sheets("sheet2").Columns(.Column).Delete
        If .Column = 1 Then Sheets("sheet2").Rows(.Row).Delete
    End If
   End With
  Next
End Sub

Only trouble is this copies all columns. How would I modify it to only copy the columns B, C, F, G, O & P?

[mjr veverka]

... On Sheet1, each row has a check box in Column A ...

? 1,048,576 check boxes ?

[Storm08]

? 1,048,576 check boxes ?

Maybe not that many.

There will be up to 300 rows populated.

[nigelog]

I have two pieces of code that will probably, when combined, sort this but please attach a workbook as I have no inclination of re creating....a sample would do with dummy data

[Storm08]

Here's the sample document.

If you could make it work in this document, that'd be brilliant.

[Storm08]

Is this enough information to go on?

[Storm08]

Don't mean to bump this, but I would like to get a solution to this asap.

[Storm08]

Anybody?

[nigelog]

Finally had a chance to look at this.....there is also code to add the checkboxes as they have to be linked to the rows to reference them

Sub AddCheckBox()
Dim cell As Range
Dim Lrow As Long
Dim Frow As Long
With Worksheets("Sheet1")
Frow = 8


Lrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each cell In Range("b8:b" & Lrow)
  With ActiveSheet.CheckBoxes.Add(cell.Left, _
     cell.Top, cell.Width, cell.Height)
     .LinkedCell = cell.Offset(, 0).Address(External:=T)
     .Interior.ColorIndex = 37
     .Caption = ""

  End With
Next
End With

End Sub


Sub DelCheckBox()
Dim Lrow As Long
Dim Frow As Long
Dim rng As Range
With Worksheets("Sheet1")
Lrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each cell In Range("A8:A" & Lrow)
.CheckBoxes.Delete


Next

End With
End Sub
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row - 1
    Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(8, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(8, i + 2)
Next
End With
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
WorkSheets("Sheet2").Activate
End Sub

[Storm08]

Finally had a chance to look at this.....there is also code to add the checkboxes as they have to be linked to the rows to reference them

Sub AddCheckBox()
Dim cell As Range
Dim Lrow As Long
Dim Frow As Long
With Worksheets("Sheet1")
Frow = 8


Lrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each cell In Range("b8:b" & Lrow)
  With ActiveSheet.CheckBoxes.Add(cell.Left, _
     cell.Top, cell.Width, cell.Height)
     .LinkedCell = cell.Offset(, 0).Address(External:=T)
     .Interior.ColorIndex = 37
     .Caption = ""

  End With
Next
End With

End Sub


Sub DelCheckBox()
Dim Lrow As Long
Dim Frow As Long
Dim rng As Range
With Worksheets("Sheet1")
Lrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each cell In Range("A8:A" & Lrow)
.CheckBoxes.Delete


Next

End With
End Sub
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row - 1
    Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(8, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(8, i + 2)
Next
End With
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
WorkSheets("Sheet2").Activate
End Sub

Hi nigelog,

Thank you very much for helping me out with this. It is working brilliantly!

I have a question if you dont mind? If I wanted to change the row the range started from, how would this be done? I have realised that I would need to copy from row 3 instead of row 8.

All the best,
Joe

[nigelog]

chane the references to "8" to "3" in the copy section of the code.... thanks for the rep joe

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row - 1
    Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(3, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(3, i + 2)
Next
End With
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
WorkSheets("Sheet2").Activate
End Sub

[Storm08]

chane the references to "8" to "3" in the copy section of the code.... thanks for the rep joe

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row - 1
    Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(3, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(3, i + 2)
Next
End With
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
WorkSheets("Sheet2").Activate
End Sub

Ah right! Simple enough! Thank you.

Also, one last query I have. One of the columns that is copied contains formula. On Sheet1 this is in Column "P", and contains the following: "=F8*O8". When being copied into Sheet2, this moves into Column "G" and should become: "=D8*F8", due to the formula being relative. But what I actually get on Sheet2 in Column "G" is: "#REF!*F8". This suggests that I should be using an absolute formula, but I shouldn't need to due to the cells needing to change when being copied to Sheet2.

Any ideas?

P.S - You're welcome for the rep! Well earned!

[nigelog]

Change this part for new last row value on sheet2

    With Worksheets("Sheet2")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row
    .Range("g8:g" & LastRow).Formula = "=d8*f8"
    End With

[nigelog]

I'll have a look

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row - 1
    Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(3, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(3, i + 2)
     
Next
End With


    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    With Worksheets("Sheet2")
    .Range("g8:g" & LastRow).Formula = "=d8*f8"
    End With
    Worksheets("Sheet2").Activate
End Sub

[Storm08]

Thanks very much!

[mjr veverka]

And add a dot to the code:

    .Range("b" & .Rows.Count).End(xlUp).Row
    .Range("A8:a" & LastRow).AutoFilter ...

And move "If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False" up to "With ... End With", in the form:

    If .AutoFilterMode = True Then .AutoFilterMode = False

Without it, if you run a macro from a different sheet than 'Sheet1', strange things can happen ...
From Ms description:
"Using this property without an object qualifier is equivalent to using ActiveSheet.Rows"
It also applies to other things ...

[nigelog]

Well spotted perucha, ta

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim colstocopy() As Variant
    colstocopy = Array(2, 3, 6, 7, 15, 16)
    
With Worksheets("Sheet1")
    LastRow = .Range("b" & Rows.Count).End(xlUp).Row
    .Range("A8:a" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
    
           For i = 0 To UBound(colstocopy)
     .Range(Cells(3, colstocopy(i)), Cells(LastRow, colstocopy(i))).Copy Sheets("Sheet2").Cells(3, i + 2)
     
Next
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
End With

    Application.ScreenUpdating = True
    With Worksheets("Sheet2")
    .Range("g8:g" & LastRow).Formula = "=d8*f8"
    End With
    Worksheets("Sheet2").Activate
End Sub

[Storm08]

Thanks very much. This has corrected the #REF! errors. However, there is more than one formula in the end column. Is there another way to achieve this? Sorry I hadn't explained his before.

Also, when I un-check a check box on Sheet1, I get the run-time error '1004':We can't do that to a merged cell.

I have attached an up to date file to demonstrate.

[nigelog]

Hi
it is difficult to see all the connections in your sample, please enter representative data in the first two sub heading layouts as you have some formatted for currency yet others are calculated and not formatted. Also rename columns as they would appear as that would help seeing what is going on

ta

i cant recreate the merged cell problem, works fine here

[Storm08]

Sorry, I removed too many headings!

[nigelog]

In the first sheet I would like to see a few rows as they are populated - Unit is carried to second sheet but is involved in no calculations - it could be feet inches or sq miles - be handy to know what was what

Edit


As the second sheet is basically a summary report (not an editable document-that should be in the first sheet) then I would suggest no formulas in sheet 2 only values. Some of your calculations involve cells not carried over at all.

[Storm08]

Unit is not a cell that is included in any calculation, it just shows what the Qty is of, e.g - hours, days, metres, etc. It can vary.

The calculation between the columns is Total = Qty x Rate. In the "Total" column, each sub-heading row should calculate the sum of the cells under that sub-heading.

Also, if a new row is inserted into Sheet1, is it possible for the sheet to automatically add a new checkbox for that row?

[nigelog]

To enter rows I could only delete and add checkboxes again to keep link

I had no time to try ans store/retrieve the checkboxes previous value so I checked them all (not a great solution but temporary)

Update client copies only values now - should not be a working document but a report

right click for normal excel options and look for "control" - click on it for option menu to appear on sheet1

hope that helps

Edit few niggles ironed out

[Storm08]

Hi again,

This is working almost perfectly now! I have to thank you for coding these functions, and also for your patience with me!

I have had a thought about the formula in the total column not working. Is it possible to do something along the lines of:

If row fill colour = rgb(246, 247, 248), calculate the sum of cells below. The range end is when the code gets to another cell with the fill colour of rgb(246, 247, 248). If this is possible and you put this code after the one you came up with previously and use an If Else statement so it doesn't run on blank rows, I think that'd be it.

Everything else is spot on and is working well. It's just that Sheet2 needs to be able to work on its own.

EDIT:
Ah ha! Here's what I was looking for:

Function SumToColor()
Dim Result
For counter = ActiveCell.Row + 1 To ActiveCell.Row + 5000
    If Cells(counter, ActiveCell.Column).Interior.Color = RGB(246, 247, 248) Then Exit For
    Result = Result + Cells(counter, ActiveCell.Column).Value
Next
SumToColor = Result
End Function

[nigelog]

You can do what what you are looking for by setting ranges with "special cells" such as formatting. A few people on here I have seen have a lot of knowledge in this area such as jindon

Probably best if you start a new thread with just that request "how to sum cells to the next special cell" and utilise that later in the code to select the special cells in sheet 2 and enter a formula....

[Storm08]

Ah right, excellent. Thanks for pointing me in the right direction, I'll start a new thread and reference this one.

Thank you very much for all of your help, I really appreciate it!

[nigelog]

Sorted

summing cells on headers will automatically shrink and grow as lines are added deleted

inserted rows get an linked checkbox

all data now gets copied to Sheet2


Last 3 checkboxes on sheet 1 must always be clicked. The headers sum the values by looking for the next cell of the same format - that light shaded line needs to be above the darker shaded one to avoid it including the sheet total

[Storm08]

Hi nigelog,

Apologies for the delay, I hadn't received an email alert for the thread.

Thanks very much for the update, I'll have a go and let you know how I get on.

[Storm08]

Cant seem to access the "Control Panel" when right clicking. The code for it doesn't seem to be there either?

[nigelog]

Hi, try this workbook. Must have linked wrong one

just noticed this leaves data in the clipboard - add the line

Application.CutCopyMode = False

before the end of the copy rows sub

[Storm08]

Hi again,

This is absolutely spot on! Can't thank you enough for all of your work on this!

If you don't mind, I have one last function that I have found would need to be added to this sheet. Is that okay?

Is it possible to recall which checkboxes were selected when adding the checkboxes back?

[nigelog]

Hi
I thought of that when I was doing but didn't have time to look at. The checkboxes are linked to a cell on the row and record true or false. That list would have to to be written to either a helper column or an array and replaced to their correct cell, as in taking taking into account what row was added etc. I will take a look at but I think now on this occasion you should start a new thread asking that specific question. It may be answered a lot faster than I could manage.

[Storm08]

Hi
I thought of that when I was doing but didn't have time to look at. The checkboxes are linked to a cell on the row and record true or false. That list would have to to be written to either a helper column or an array and replaced to their correct cell, as in taking taking into account what row was added etc. I will take a look at but I think now on this occasion you should start a new thread asking that specific question. It may be answered a lot faster than I could manage.

Hi,

No worries at all. The theory behind the recall function makes perfect sense, but I understand how time consuming writing and testing code can be! I'll start a new thread for this item.

Thanks very much for all of your help, it's greatly appreciated!

Kind Regards,
Joe

[nigelog]

I reckon the best way is to only add a checkbox the row that is highlighted when a row inserted (rather than deleting them all and replacing. I am trying to reference the inserted row but can't quite get the syntax
this doesn't work

  With Rows(ActiveCell.Row).CheckBoxes.Add(cell.Left, _
     cell.Top, cell.Width, cell.Height)
     .LinkedCell = cell.Offset(, 0).Address(External:=T)
     .Interior.ColorIndex = 37
     .Caption = ""
  End With

I suggest trying to adjust the worksheet change sub to not reference the add and delete subs in module 7 but to just add a checkbox to the inserted row

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call TagCellManager(Target)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim CurCel As Range, CurRow As Range
    Dim TagCel As Range, TagRow As Range
    Dim NxtCel As Range, NxtRow As Range
    Dim r As Range, ws As Worksheet
    Set CurCel = Target.Item(1, 1)
    Set CurRow = Cells(CurCel.Row, 1)
    Set TagCel = Cells(CurCel.Row + Target.Rows.Count, CurCel.Column)
    Set TagRow = Cells(CurCel.Row + Target.Rows.Count, 1)
    Set NxtCel = TagCel.Offset(Target.Rows.Count, 0)
    Set NxtRow = TagRow.Offset(Target.Rows.Count, 0)

    If TagCel.ID <> "" And TagRow.ID <> "" Then

    ElseIf NxtCel.ID <> "" Or NxtRow.ID <> "" Then

        

  With Rows(ActiveCell.Row).CheckBoxes.Add(cell.Left, _
     cell.Top, cell.Width, cell.Height)
     .LinkedCell = cell.Offset(, 0).Address(External:=T)
     .Interior.ColorIndex = 37
     .Caption = ""
  End With

        
        'Call Module7.DelCheckBox
        'Call Module7.AddCheckBox
        'Call Module2.SelectAllCheckBoxes
        Set Target = Range(NxtCel.ID)
        Call TagCellManager(Target)
    ElseIf CurCel.ID <> "" Or CurRow.ID <> "" Then
        'MsgBox "row deleted"
        'Call Module7.DelCheckBox
        'Call Module7.AddCheckBox
        'Call Module2.SelectAllCheckBoxes
        Set Target = Range(CurCel.ID)
        Call TagCellManager(Target)
    End If
End Sub

let me know how you get on

[nigelog]

This will add a checkbox to only the inserted row so all others keep their value (with thanks to Arkadi on here), rather than deleting all and re adding all checkboxes

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call TagCellManager(Target)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim CurCel As Range, CurRow As Range
    Dim TagCel As Range, TagRow As Range
    Dim NxtCel As Range, NxtRow As Range
    Dim r As Range, ws As Worksheet

    Set CurCel = Target.Item(1, 1)
    Set CurRow = Cells(CurCel.Row, 1)
    Set TagCel = Cells(CurCel.Row + Target.Rows.Count, CurCel.Column)
    Set TagRow = Cells(CurCel.Row + Target.Rows.Count, 1)
    Set NxtCel = TagCel.Offset(Target.Rows.Count, 0)
    Set NxtRow = TagRow.Offset(Target.Rows.Count, 0)

    If TagCel.ID <> "" And TagRow.ID <> "" Then

    ElseIf NxtCel.ID <> "" Or NxtRow.ID <> "" Then
Dim myCell As Range
Dim myBox As Object

Set myCell = Selection.Cells(1)
Set myBox = ActiveSheet.CheckBoxes.Add(myCell.Left, _
     myCell.Top, myCell.Width, myCell.Height)
myBox.LinkedCell = myCell.Offset(, 0).Address(External:=T)
myBox.Interior.ColorIndex = 37
myBox.Caption = ""
      

        Set Target = Range(NxtCel.ID)
        Call TagCellManager(Target)
    ElseIf CurCel.ID <> "" Or CurRow.ID <> "" Then
    
        Set Target = Range(CurCel.ID)
        Call TagCellManager(Target)
    End If
End Sub

if this sorts your request can you mark as solved. Rgds

[Storm08]

Hiya,

Thanks for providing a solution! it works when inserting the check box, but after it's done that, it selects all of the check boxes rather than leaving them in the state they were before.

[nigelog]

Code above definitely does not do that

[Storm08]

It doesn't in the document you just posted. Must have been me putting it somewhere incorrect.

However, when I try to click the "Client Update" button, it says "We can't do that to a merged cell".

[nigelog]

There are no merged cells in that workbook so the error must be in the workbook you have put the code into. Generally merged are nothing but grief - use centre across selection instead - or find another way around using them


Edit: the merged cells in your original sample workbook are C4:C5 remove the merging and should be ok

Edit: They are in workbook as well so its not that

Edit: Code changed to check that checkbox links are correct when rows are entered....

[rara2425]

pls inbox your excel sheet, i will support you.

[kmomchev]

Hi,

I can help you as well. Is Storm082.xlsm mentioned above, the last version you are working on?

Best, Konstantin