Search code examples
excelvba

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

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!

Solution
    • 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