在excl中用VBA查找内容并设置字体及大小 - Excel/VBA论坛

已结贴√ 问题点数：10 回复次数：5

在excl中用VBA查找内容并设置字体及大小

要求：1、用VBA查找班级课程表、教师课程表中的“*课程表”，并设置“*课程表”的字体为“仿宋_GB2312”，字号为“20”,字体颜色为红色，背景色为黄色。
2、用VBA查找班级课课表、教师课程表中的“早自习、上午、下午、晚自习”，并设置“早自习、上午、下午、晚自习”的字体为“仿宋_GB2312”，字号为“18”号。

VBA查找内容并设置字体及大小.rar (32.02 KB)

搜索更多相关主题的帖子: 课程表　字体　 VBA　查找　大小　

第 2 楼

得分:7

供你参考 ,只写了第一个要求, 第二个要求你参考这个代码,举一反三 ,不难写出 :

程序代码：

Sub FindCell()
' 查找班级课程表、教师课程表中的“*课程表”，
'
Dim sht As Worksheet, rng As Range, lStop As Boolean
Dim arrsht()

arrsht = Array("教师课程表", "班级课程表")
Worksheets("要求").Activate
For Each shtName In arrsht

    lStop = False
    Set sht = Worksheets(shtName)
    sht.Activate
    sht.Range("A1").Activate
    
    If InStr(1, sht.Range("A1").Value, "课程表", vbTextCompare) > 0 Then
        Call SetFont1(sht.Range("A1"))
    End If
    
    While lStop = False
        Set rng = Cells.Find(What:="课程表", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , MatchByte:=False, SearchFormat:=False)
        ad1 = rng.AddressLocal
        rng.Activate
        If rng.Row = 1 Then
            lStop = True
        Else
            Call SetFont1(rng)
            rng = sht.Cells.FindNext(After:=ActiveCell)
            ad1 = rng.AddressLocal
        End If
    Wend
Next shtName
End Sub


Sub SetFont1(rng1 As Range)
'设置 字体为“仿宋_GB2312”，字号为“20”,字体颜色为红色，背景色为黄色。

    With rng1.Font
        .Name = "仿宋_GB2312"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With rng1.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With rng1.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
End Sub

[此贴子已经被作者于2022-6-13 16:24编辑过]

第 3 楼

得分:0

谢谢！

第 4 楼

得分:0

回复 2楼厨师王德榜

谢谢老师！

第 5 楼

得分:0

完整代码在这里

程序代码：

Sub FindCell()
' 查找班级课程表、教师课程表中的“*课程表”，
'
Dim sht As Worksheet, rng As Range, lStop As Boolean
Dim arrsht()

arrsht = Array("教师课程表", "班级课程表")
Worksheets("要求").Activate
For Each shtName In arrsht

    lStop = False
    Set sht = Worksheets(shtName)
    sht.Activate
    sht.Range("A1").Activate
    
    If InStr(1, sht.Range("A1").Value, "课程表", vbTextCompare) > 0 Then
        Call SetFont1(sht.Range("A1"))
    End If
    
    While lStop = False
        Set rng = Cells.Find(What:="课程表", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , MatchByte:=False, SearchFormat:=False)
        ad1 = rng.AddressLocal
        rng.Activate
        If rng.Row = 1 Then
            lStop = True
        Else
            Call SetFont1(rng)
            rng = sht.Cells.FindNext(After:=ActiveCell)
            ad1 = rng.AddressLocal
        End If
    Wend
Next shtName
End Sub


Sub FindCell2()
' 查找班级课课表、教师课程表中的“早自习、上午、下午、晚自习”
Dim sht As Worksheet
Dim rng As Range
Dim arr11()

arrsht = Array("教师课程表", "班级课程表")
Worksheets("要求").Activate
For Each shtName In arrsht

    Set sht = Worksheets(shtName)
    sht.Activate
    sht.Range("A1").Activate
    Set rng = Range(sht.Cells(1, 1), sht.Cells(sht.UsedRange.Rows.Count, 1))
    arr11 = rng.Value
    
    For ii = 1 To UBound(arr11, 1)
        If InStr(1, "早自习、上午、下午、晚自习", arr11(ii, 1), vbTextCompare) > 0 Then
            Set rng = sht.Cells(ii, 1)
            Call SetFont1(rng, 2)
        End If
    Next ii

Next shtName

End Sub


Sub SetFont1(rng1 As Range, Optional itype As Integer = 0)
'设置 字体为“仿宋_GB2312”，字号为“20”,字体颜色为红色，背景色为黄色。

    With rng1.Font
        .Name = "仿宋_GB2312"
        .Size = IIf(itype = 0, 20, 18)
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
If itype = 0 Then
    With rng1.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With rng1.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
End If
End Sub

第 6 楼

得分:0

回复 5楼厨师王德榜

非常感谢老师的代码