VBA从A列取涂上粗黑字体到B列

jylai

这代码不起作用 =CB(A2:A10)

Function CB(rng As Range)
    Dim cell As Range
    For Each cell In rng
        cell.Offset(0, 1).Value = cell.Value
        cell.Offset(0, 1).Font.Bold = True
    Next cell
End Function

黄色区域是最终结果

3190496160

Sub 取数()
r = Cells(Rows.Count, 1).End(xlUp).Row
ReDim ar(1 To r, 1 To 1)
For i = 2 To r
    If Cells(i, 1) <> "" Then
        If Cells(i, 1).Font.Bold = True Then
            n = n + 1
            ar(n, 1) = Cells(i, 1)
        End If
    End If
Next i
If n = "" Then MsgBox "没有符合条件的数据！": End
Columns(2) = Empty
[b2].Resize(n, 1) = ar
MsgBox "ok!"
End Sub

3190496160

q1.rar (11.47 KB, 下载次数: 11)

2024-2-13 10:08 上传

点击文件名下载附件

高个子

任何一个函数都无法加粗，这个只能用sub来解决

jylai

3190496160 发表于 2024-2-13 10:08

老师您太牛了，新年快乐，龙年行大运

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, r&
   
    With Range("A2", Cells(Rows.Count, "A").End(xlUp)) '.Value
        ar = .Value
        For i = 1 To UBound(ar)
            If .Cells(i, 1).Font.Bold = True Then
                 r = r + 1
                 ar(r, 1) = ar(i, 1)
            End If
        Next i
    End With
   
    Columns("B").ClearContents
    If r Then
        [B2].Resize(r) = ar
    Else
        MsgBox "未找到！"
    End If
    Beep
End Sub

gwjkkkkk

参与一下。。。

jylai

老师可以不增加这行一样ws.Range("B2:B" & lastRow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp，B列可不留空（请看涂黄色的）

jylai

老师  8楼有新问题再次求助

gwjkkkkk

jylai 发表于 2024-2-14 08:26
老师  8楼有新问题再次求助

根据你的代码：
1.A列中有空白的单元格，但格式是加粗，把空值带进来了，可加个判断把空值去除。
2.j 起如始值是2，应该判断 j=2 then...