Untitled

mail@pastecode.io avatar
unknown
vbscript
7 months ago
6.4 kB
4
Indexable
Never
Private Sub Worksheet_Change(ByVal Target As Range)

With Target
    If (.Row = 5 Or .Row = 6 Or .Row = 9) And .Column = 4 Then
        Range("X6:AJ65536").ClearContents
        temp = 0
        Read_Inf
        For MDF_num = 1 To 3
            If Sheets("MDF").Cells(7, (MDF_num - 1) * 14 + 3) = "" Then Set mpdata = Sheets("MDF").Cells(6, (MDF_num - 1) * 14 + 2) Else Set mpdata = Sheets("MDF").Range(Sheets("MDF").Cells(6, (MDF_num - 1) * 14 + 2), Sheets("MDF").Cells(6, (MDF_num - 1) * 14 + 3).End(xlDown))
            For i = 1 To mpdata.Rows.Count
                If i = 65530 Then
                    下一個年齡 = mpdata(i + 1, 4)
                    下二個年齡 = Sheets("MDF").Cells(6, MDF_num * 14 + 5)
                ElseIf i = 65531 Then
                    下一個年齡 = Sheets("MDF").Cells(6, MDF_num * 14 + 5)
                    下二個年齡 = Sheets("MDF").Cells(7, MDF_num * 14 + 5)
                Else
                    下一個年齡 = mpdata(i + 1, 4)
                    下二個年齡 = mpdata(i + 2, 4)
                End If
                If MDF_num > 1 And i = 1 Then
                    前一個年齡 = Sheets("MDF").Cells(6, (MDF_num - 2) * 14 + 5)
                Else
                    前一個年齡 = mpdata(i - 1, 4)
                End If
                If mpdata(i, 2) = Cells(5, 4) And (Left(Cells(9, 4), 1) + 0 = 6 Or Left(Cells(9, 4), 1) + 0 = mpdata(i, 7)) Then
                    If Cells(6, 4) = "Total" Then
                        Range(Cells(6 + temp, 24), Cells(6 + temp, 31)).Value = Sheets("MDF").Range(Sheets("MDF").Cells(5 + i, (MDF_num - 1) * 14 + 2), Sheets("MDF").Cells(5 + i, (MDF_num - 1) * 14 + 9)).Value
                        For dis_num1 = 1 To 5
                            If Cells(6 + temp, 29) < dis_SA_inf(Cells(6 + temp, 24), Cells(6 + temp, 26), dis_num1 + 1) Or dis_SA_inf(Cells(6 + temp, 24), Cells(6 + temp, 26), dis_num1 + 1) = 0 Then
                                Exit For
                            End If
                        Next dis_num1
                        Cells(6 + temp, 36) = dis_num1
                        temp = temp + 1
                    ElseIf Cells(6, 4) = "Key Age" Then
                        If mpdata(i, 4) Mod 10 = 0 Or (i = 1 And MDF_num = 1) Or mpdata(i, 4) > 下一個年齡 Or mpdata(i, 4) < 前一個年齡 Then
                            Range(Cells(6 + temp, 24), Cells(6 + temp, 31)).Value = Sheets("MDF").Range(Sheets("MDF").Cells(5 + i, (MDF_num - 1) * 14 + 2), Sheets("MDF").Cells(5 + i, (MDF_num - 1) * 14 + 9)).Value
                            For dis_num1 = 1 To 5
                                If Cells(6 + temp, 29) < dis_SA_inf(Cells(6 + temp, 24), Cells(6 + temp, 26), dis_num1 + 1) Or dis_SA_inf(Cells(6 + temp, 24), Cells(6 + temp, 26), dis_num1 + 1) = 0 Then
                                    Exit For
                                End If
                            Next dis_num1
                            Cells(6 + temp, 36) = dis_num1
                            temp = temp + 1
                        End If
                        AMP = AMP + mpdata(i, 8)
                        If (Int((mpdata(i, 4) + 5) / 10) <> Int((下一個年齡 + 5) / 10) Or ((i = 1 Or mpdata(i, 4) < 前一個年齡) And mpdata(i, 4) Mod 10 > 4) Or (下一個年齡 > 下二個年齡 And (Int(下一個年齡 - 1) Mod 10 < 4))) Then
                            Cells(5 + temp, 31) = max(AMP, 10 ^ -10)
                            AMP = 0
                        End If
                    End If
                End If
            Next i
        Next MDF_num
    End If

    If (.Row = 7 Or .Row = 8) And .Column = 8 Then
        If Sheets("Setup").Range("X7") = "" Then Set MP = Sheets("Setup").Range("X6:AE6") Else Set MP = Sheets("Setup").Range("X6", Sheets("Setup").Range("AE6").End(xlDown))
        For i = 1 To MP.Rows.Count
            If Sheets("Setup").Cells(7, 8) = "Total" And Sheets("Setup").Cells(8, 8) = "Total" Then
                For k = 1 To 12
                    MP(i, k).Interior.Color = 13431551
                Next k
            ElseIf Sheets("setup").Cells(7, 8) = "" Or Sheets("Setup").Cells(8, 8) = "" Then
                For k = 1 To 12
                    MP(i, k).Interior.Color = 14277081
                Next k
            ElseIf Sheets("Setup").Cells(7, 8) <> "Total" And Sheets("Setup").Cells(8, 8) <> "Total" Then
                If Right(Sheets("setup").Cells(7, 8), 1) = "M" Then MF = 1 Else MF = 2
                AGE = Left(Sheets("setup").Cells(7, 8), Len(Sheets("setup").Cells(7, 8)) - 1) + 0
                If MP(i, 4) = AGE And MP(i, 5) = MF And MP(i, 3) = Sheets("Setup").Cells(8, 8) Then
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 13431551
                    Next k
                Else
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 14277081
                    Next k
                End If
            ElseIf Sheets("Setup").Cells(8, 8) = "Total" Then
                If Right(Sheets("setup").Cells(7, 8), 1) = "M" Then MF = 1 Else MF = 2
                AGE = Left(Sheets("setup").Cells(7, 8), Len(Sheets("setup").Cells(7, 8)) - 1) + 0
                If MP(i, 4) = AGE And MP(i, 5) = MF Then
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 13431551
                    Next k
                Else
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 14277081
                    Next k
                End If
            ElseIf Sheets("Setup").Cells(7, 8) = "Total" Then
                If MP(i, 3) = Sheets("Setup").Cells(8, 8) Then
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 13431551
                    Next k
                Else
                    For k = 1 To 12
                        MP(i, k).Interior.Color = 14277081
                    Next k
                End If
            End If
        Next i
    End If

End With

End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

End Sub

Private Sub Worksheet_PivotTableBeforeAllocateChanges(ByVal TargetPivotTable As PivotTable, ByVal ValueChangeStart As Long, ByVal ValueChangeEnd As Long, Cancel As Boolean)

End Sub
Leave a Comment