Use specified macro to move data from multiple columns to another sheet PLUS assign a number to checkboxes when macro runs

by

I am using the following macro in excel to move data in columns “C”, “D through J” depending on the checkbox selected, and “K” if the value in column “O” is a 1 for each row.

I would like to add the functionality of using a 0-6 value for the checkboxes to populate a date in a specific cell of the sheet the data is being moved to.

There is already a base date on a previous sheet in this workbook I will add to and the date field in the sheet this data is being sent to is formatted as a date. All I need to do is designate IF Monday is checked add 0, If Tuesday is checked add 1, and so on.

Below is the macro:

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

This is what the workbook looks like:

Workbook

The base date cell is located at “=Begin!F9” in the “Begin” sheet of the workbook.

Let’s call the final location this data will be sent “=’OtherSheet’!Q2”.

Any help on this would be greatly appreciated!

  • to populate a date in a specific cell What’s the location of specific cel? Is it possible uses checked more than one checkbox? If so, how to populate the specific cel?

    – 




  • The location of the cell is: ‘OtherSheet’!Q2 and selecting more than one day of the week goes against the fundamental purpose of this workbook. Everything it does is based on the base date at location ‘Begin’!F9 and the single day selected in the checkbox. I am adding another sheet to the workbook that will encapsulate all the functions of this process into one file.

    – 

  • populate a date in a specific cell of the sheet the data is being moved to You have to specify two cells, one for the date (base date + x), the other is for the extracted data.

    – 

  • @taller I believe I have. The one for the date is: ‘OtherSheet’!Q2 and the extracted data cell is: ‘Begin’!F9. The first sheet in this workbook is called Begin and has the base date in cell: F9. The other sheet that the result of this function will populate is being called: OtherSheet for the sake of this question and the cell it will need (base date + x) added to is Q2

    – 




  • What’s the other cell? It is used in Range("A20").Resize(iR, iC).Value = arrRes. What’s the name of sheet which holds the source table? It is important to qualify all range with sheet object coz the code manipulates multiple sheets.

    – 




  • It is crucial to qualify all ranges with sheet objects because the code manipulates multiple sheets.
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
    Dim aWeek, vWeek, aCheck(), Chk_Cnt As Long
    Dim SrcSht As Worksheet, DesSht As Worksheet, BeginSht As Worksheet
    Const COL_BASE = 4
    ' modify sheet names as needed
    Set SrcSht = Sheets("Date") ' source table
    Set DesSht = Sheets("OtherSheet") ' output
    Set BeginSht = Sheets("Begin") ' base date
    aWeek = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
    ReDim aCheck(UBound(aWeek))
    For i = 0 To UBound(aWeek)
        aCheck(i) = (SrcSht.Shapes("chk" & aWeek(i)).OLEFormat.Object.Value = 1)
        If aCheck(i) Then
            Chk_Cnt = Chk_Cnt + 1
            With BeginSht.Range("F9") ' get base date
                If IsDate(.Value) Then DesSht.Range("Q2").Value = .Value + i
            End With
        End If
    Next
    lastRow = SrcSht.Cells(SrcSht.Rows.Count, "C").End(xlUp).Row
    If lastRow > 8 And Chk_Cnt > 0 Then
        arrData = SrcSht.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 L2, modify as needed
    DesSht.Range("L2").Resize(iR, iC).Value = arrRes
End Sub

Leave a Comment