Question

在“O”栏的数值是每行1美元时,我将采用以下宏观方法将数据移入“C”、“D至J”栏,视所选的检查箱而定。

我要补充的是,将0-6数值用于核对箱的功能,以便把数据移至表中某一具体单元。

这份工作手册的上一个表上已经有一个基准日期,我将在表格中添加这一数据,并将这些数据作为日期发送。我需要做的是指定国际会计师联合会(IF)星期一加插0,如果对星期二加插1,等等。

以下是宏观:

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

这是《工作手册》认为的:

基准日单位位于《工作手册》“原始”表中的“=Begin!F9”。

让我们把这一数据放在最后位置上“=”。 OtherSheet !Q2.

在这方面的任何帮助将受到高度赞赏。

Answer 1

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

友情链接