# VBA基础九：画表格线及表外线的颜色定义

VBA代码

Private Sub CommandButton1_Click()
Dim arr, i&, n&, d As Object, s\$, a()
arr = Sheet1.Range("A1").CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(arr)
s = arr(i, 7) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
If Not d.Exists(s) Then
n = n + 1: ReDim Preserve a(1 To 12, 1 To n)
d(s) = arr(i, 6)
a(1, n) = arr(i, 2) '名称
a(2, n) = arr(i, 7) '材质
a(3, n) = arr(i, 3) '长
a(4, n) = arr(i, 4) '宽
a(5, n) = arr(i, 5) '厚
Else
d.Item(s) = d.Item(s) + arr(i, 6)
End If
Next
Sheet3.Range("A5:L10000").ClearContents
Sheet3.Range("A5:L10000").Borders.LineStyle = xlNone
If n = 0 Then Exit Sub
Sheet3.Range("A5").Resize(d.Count, UBound(a)) = WorksheetFunction.Transpose(a)
Sheet3.Range("G5").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
Sheet3.Range("A5").Resize(d.Count, 12).Borders.LineStyle = xlContinuous
End Sub

Sub DrawLine(StartX As Variant, StartY As Variant, EndX As Variant, EndY As Variant)
Selection.ShapeRange.Line.Weight = 2
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End Sub

Sub lqxs()
Dim ks, js, shp As Shape, a, b, a1, a2, b1, b2, x1, y1, x2
For Each shp In Sheet1.Shapes
If shp.Type = 9 Then shp.Delete
Next
ks = Range("a1").Value: js = Range("b1").Value
a = ks * 24: b = js * 24
a1 = Int(a): a2 = a - a1
b1 = Int(b): b2 = b - b1
x1 = Cells(4, a1 - 5).Left + Cells(4, a1 - 5).Width * a2: y1 = Cells(4, a1 - 5).Top + Cells(4, a1 - 5).Height * 0.5
x2 = Cells(4, b1 - 5).Left + Cells(4, b1 - 5).Width * b2
DrawLine x1, y1, x2, y1
Range("a1").Select
End Sub

Sheet3.Range("E3:F6").Interior.Color = 69000 '紫红色色块E3：F6，背景

Private Sub CommandButton3_Click()
Range("D2:G" & [G65536].End(xlUp).Row).Font.Color = -16776961 '从D列2行到G列有内容的区域行，定义色块红色字
End Sub

Sub Macro1()
For mycolumn= 1 To 100
For myrow= 2 To 5
' 从第1行到100行，vba的下标从1 开始，非传统的0开始
' 从第2列到第5列

ActiveSheet.Cells(myrow, mycolumn).Select
' 选中循环中的单元格
If ActiveCell.Value = "" Then
Else
With ActiveCell.Characters(Start:=1, Length:=0).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=1, Length:=8).Font
' 1~8字符 设置为红色
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Underline = xlUnderlineStyleNone
.Color = -16776961
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=9, Length:=1).Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.ThemeFont = xlThemeFontMinor
End With
With ActiveCell.Characters(Start:=10, Length:=5).Font
' 10~14字符 设置为深蓝色
.Name = "宋体"
.FontStyle = "常规"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Underline = xlUnderlineStyleNone
.Color = -4165632
.ThemeFont = xlThemeFontMinor
End With
Selection.Font.Bold = True
End If
Next
Next

End Sub

Private Sub CommandButton4_Click()
Sheet3.Range("E3:F6").Interior.Color = 69000 '紫红色色块E3：F6，背景
End Sub

posted @ 2020-07-16 14:28  袁氏家谱网  阅读(426)  评论(5编辑  收藏  举报