上面性别，年龄，出生日期编码已有，现求大神帮助编写黄色单元格代码，自动填内容...

pengzhen1817

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("f3")) Is Nothing Then
        Dim StrSF$, strXB$, Birth
        StrSF = Target
        Select Case Len(StrSF)
            Case 15
                Birth = Format("19" & Mid(StrSF, 7, 6), "####年##月##日")
                strXB = IIf(Right(StrSF, 1) Mod 2, "男", "女")
            Case 18
                Birth = Format(Mid(StrSF, 7, 8), "####年##月##日")
                strXB = IIf(Mid(StrSF, 17, 1) Mod 2, "男", "女")

        End Select
        Range("h4") = Birth & vbCrLf
        Range("f4") = strXB
        If strXB = "男" Then Range("J5") = "先生" Else Range("J5") = "女士"
        Range("J4") = DateDiff("yyyy", Birth, Date)
        Range("I6") = DateDiff("yyyy", Range("F6"), Date)

    End If
    Exit Sub
End Sub

sxbjzjf110

不知道能否满足楼主需求。

pengzhen1817

sxbjzjf110 发表于 2024-3-15 11:57
不知道能否满足楼主需求。

你好，打开怎么什么也没有显示。

sxbjzjf110

pengzhen1817 发表于 2024-3-15 16:11
你好，打开怎么什么也没有显示。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("f3")) Is Nothing Then
        Dim StrSF$, strXB$, Birth
        StrSF = Target
        Select Case Len(StrSF)
            Case 15
                Birth = Format("19" & Mid(StrSF, 7, 6), "####年##月##日")
                strXB = IIf(Right(StrSF, 1) Mod 2, "男", "女")
            Case 18
                Birth = Format(Mid(StrSF, 7, 8), "####年##月##日")
                strXB = IIf(Mid(StrSF, 17, 1) Mod 2, "男", "女")
        End Select
        Range("h4") = Birth & vbCrLf
        Range("f4") = strXB
        If strXB = "男" Then Range("J5") = "先生" Else Range("J5") = "女士"
        Range("J4") = DateDiff("yyyy", Birth, Date)
        Range("I6") = DateDiff("yyyy", Range("F6"), Date)
    End If

    If Target.Address = "$G$9" Or Target.Address = "$G$10" Or Target.Address = "$G$11" Or Target.Address = "$G$12" Then
        For i = 1 To 4
            If Range("G" & i + 8) <> "" Then
                Range("J" & i + 8) = DateDiff("yyyy", DateSerial(Mid(Range("G" & i + 8), 7, 4), Mid(Range("G" & i + 8), 11, 2), Mid(Range("G" & i + 8), 13, 2)), Date)
            Else
                Range("J" & i + 8) = ""
            End If
        
            If Range("J" & i + 8) >= 18 Then
                s1 = s1 + 1
                s2 = s2 + Range("J" & i + 8)
                Range("G15") = s1
                Range("G16") = Int(s2 / s1)
            End If
            If Range("J" & i + 8) <> "" Then
                s = s + 1
                Range("G14") = s
            End If
        Next
    End If
    Exit Sub
End Sub

dy83797465268

可以看看这个

dy83797465268

Sub age()
Dim i As Long
Dim count As Long

Cells(14, 7) = "": Cells(15, 7) = "": Cells(16, 7) = ""
count = 0
For i = 9 To 100
    Cells(i, 10) = Year(Date) - Mid(Cells(i, 7), 7, 4)
    count = count + 1
    Cells(14, 7) = Cells(14, 7) + 1
    If Cells(i, 10) >= 18 Then Cells(15, 7) = Cells(15, 7) + 1  '°ü&#186;&#172;18&#203;ê
    Cells(16, 7) = Cells(16, 7) + Cells(i, 10)
    If Cells(i + 1, 6) = "" Then Exit For
Next
Cells(16, 7) = Cells(16, 7) / count


End Sub