Search code examples
excelvba

Copy data from multiple columns based on boolean values from one sheet to another in same workbook

Does anyone know how to loop through a column and only select data from that row if the value of the cell is a 1 while skipping any zero value?

I am trying to automate a spreadsheet but I don't know how to make this happen.

Sheet Screenshot

I want to select a day with the checkboxes, then use a macro that copies all the data from row 9 to the end of the data set in the "C" column, the relevant day column, and the "Description" column if the "Yes / No" value in the O column for each row is a 1 and skip all the rows that are zeros.

Then "paste values" into cell "L2" of "Sheet 2"

I have a little bit of experience with excel but this is way too complicated for me.

The checkboxes are named "chkMonday", "chkTuesday", etc.

Any help would be great!

Solution
    • Assumes CheckBoxes are ActiveX control
    • Below code is change event code for the first checkbox
    • The desired data copy to A20 when users check a CheckBox
    Option Explicit
Private Sub chkMonday_Change()
    If Me.chkMonday Then
        Dim lastRow As Long, arrData, i As Long, arrRes()
        Dim Row_Cnt As Long, iR As Long
        Const COL_OFFSET = 1 ' 1-Monday, 2-Tuesday etc.
        Const OUT_COLCNT = 3
        lastRow = Me.Cells(Me.Rows.Count, "C").End(xlUp).Row
        If lastRow > 8 Then
            arrData = Me.Range("A9:O" & lastRow)
            Row_Cnt = UBound(arrData)
            ReDim arrRes(1 To Row_Cnt, 1 To OUT_COLCNT)
            iR = 0
            For i = LBound(arrData) To Row_Cnt
                If arrData(i, 15) = 1 Then
                    iR = iR + 1
                    arrRes(iR, 1) = arrData(i, 3)
                    arrRes(iR, 2) = arrData(i, 3 + COL_OFFSET)
                    arrRes(iR, 3) = arrData(i, 11)
                End If
            Next
        End If
        ' Output starts from cell A20, modify as needed
        Range("A20").Resize(iR, OUT_COLCNT).Value = arrRes
    End If
End Sub

    enter image description here

    • If users want to check multiple CheckBoxes first, then run the code to extract data
    • Two options for Forms control and ActiveX Control
    Option Explicit

Sub Demo()
    Dim lastRow As Long, arrData, i As Long, arrRes()
    Dim Row_Cnt As Long, iR As Long, j As Long, iC As Long
    Const COL_BASE = 4
    Dim aWeek, vWeek, aCheck(), Chk_Cnt As Long
    aWeek = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
    ReDim aCheck(UBound(aWeek))
    For i = 0 To UBound(aWeek)
        ' For ActiveX Control
        ' aCheck(i) = ActiveSheet.Shapes("chk" & aWeek(i)).OLEFormat.Object.Object.Value
        ' For Forms Control
        aCheck(i) = (ActiveSheet.Shapes("chk" & aWeek(i)).OLEFormat.Object.Value = 1)
        If aCheck(i) Then Chk_Cnt = Chk_Cnt + 1
    Next
    lastRow = Cells(Rows.Count, "C").End(xlUp).Row
    If lastRow > 8 And Chk_Cnt > 0 Then
        arrData = Range("A9:O" & lastRow)
        Row_Cnt = UBound(arrData)
        ReDim arrRes(1 To Row_Cnt, 1 To Chk_Cnt + 2)
        iR = 0
        For i = LBound(arrData) To Row_Cnt
            If arrData(i, 15) = 1 Then
                iR = iR + 1
                arrRes(iR, 1) = arrData(i, 3)
                iC = 2
                For j = 0 To UBound(aCheck)
                    If aCheck(j) Then
                        arrRes(iR, iC) = arrData(i, COL_BASE + j)
                        iC = iC + 1
                    End If
                Next
                arrRes(iR, iC) = arrData(i, 11)
            End If
        Next
    End If
    ' Output starts from cell A20, modify as needed
    Range("A20").Resize(iR, iC).Value = arrRes
End Sub

    enter image description here