| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
共有 904 人关注过本帖
标题:在excl中用VBA查找内容并设置字体及大小
只看楼主 加入收藏
shuikouzx202
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2021-11-20
结帖率:100%
收藏
已结贴  问题点数:10 回复次数:5 
在excl中用VBA查找内容并设置字体及大小
要求:1、用VBA查找班级课程表、教师课程表中的“*课程表”,并设置“*课程表”的字体为“仿宋_GB2312”,字号为“20”,字体颜色为红色,背景色为黄色。
      2、用VBA查找班级课课表、教师课程表中的“早自习、上午、下午、晚自习”,并设置“早自习、上午、下午、晚自习”的字体为“仿宋_GB2312”,字号为“18”号。


VBA查找内容并设置字体及大小.rar (32.02 KB)
搜索更多相关主题的帖子: 课程表 字体 VBA 查找 大小 
2022-06-13 14:45
厨师王德榜
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:160
帖 子:846
专家分:4134
注 册:2013-2-16
收藏
得分: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编辑过]

2022-06-13 16:14
shuikouzx202
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2021-11-20
收藏
得分:0 
谢谢!
2022-06-13 16:47
shuikouzx202
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2021-11-20
收藏
得分:0 
回复 2楼 厨师王德榜
谢谢老师!
2022-06-13 16:47
厨师王德榜
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:160
帖 子:846
专家分:4134
注 册:2013-2-16
收藏
得分: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

2022-06-13 17:31
shuikouzx202
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2021-11-20
收藏
得分:0 
回复 5楼 厨师王德榜
非常感谢老师的代码
2022-06-13 17:41
快速回复:在excl中用VBA查找内容并设置字体及大小
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.083325 second(s), 9 queries.
Copyright©2004-2022, BCCN.NET, All Rights Reserved