常用代码归集

百旺表格

好帖。学习。在学校，努力进步

jsgj2023

Sub 保护指定的单元格区域()
    Dim myshape As Shape
    Dim myRange As Range
    Dim ws As Worksheet
    Set ws = Worksheets(1)    '指定工作表
    Set myRange = ws.Range("C6:E10")    '指定要保护的单元格区域
    '删除所有Shape对象
    For Each myshape In ws.Shapes
        With myshape
            If .Type = msoFormControl Or .Type = msoOLEControlObject Then
            Else
                .Delete
            End If
        End With
    Next
    '插入一个矩形对象
    With myRange
        Set myshape = ws.Shapes.AddShape(msoShapeRectangle, _
            Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
    End With
    With myshape    '将矩形的内部填充和线条都设置为不可见
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        .OnAction = "myshape"    '指定一个假宏
    End With
    MsgBox "单元格区域" & myRange.Address(False, False) _
        & "已经被保护起来了!不能用鼠标操作这些单元格!", vbExclamation
    Set myshape = Nothing
    Set myRange = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 获取shape对象的左侧距离和顶部距离()
    Dim myShape As Shape
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    Set myShape = ws.Shapes(2)
    MsgBox "该Shape对象的左侧距离：" & myShape.Left & vbCrLf _
        & "该Shape对象的顶部距离：" & myShape.Top
    Set myShape = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 插入一个矩形对象并设定起格式添加超链接()
Dim myshape As Shape
Dim ws As Worksheet
Set ws = Worksheets(1)
Set myshape = ws.Shapes.AddShape(msoShapeRectangle, 50, 150, 300, 40)
With myshape
    With .TextFrame.Characters
        .Text = "单击将激活工作表Sheet3"
        With .Font
            .Name = "华文行楷"
            .FontStyle = "常规"
            .Size = 22
            .ColorIndex = 7
        End With
    End With
    With .TextFrame
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    .Placement = xlFreeFloating
End With
myshape.Select
With Selection.ShapeRange.Line
    .Weight = 1
    .DashStyle = msoLineSolid
    .Style = msoLineSingle
    .Transparency = 0
    .Visible = msoTrue
    .ForeColor.SchemeColor = 40
    .BackColor.RGB = RGB(255, 255, 255)
End With
With Selection.ShapeRange.Fill
    .Transparency = 0
    .Visible = msoTrue
    .ForeColor.SchemeColor = 41
    .OneColorGradient msoGradientHorizontal, 4, 0.23
End With
ws.Range("a1").Select
ws.Hyperlinks.Add anchor:=myshape, Address:="", _
SubAddress:="Sheet3!A1", ScreenTip:="激活工作表Sheet3"
Set myshape = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 插入一个矩形对象并将其充满指定的单元格区域()
Dim myshape As Shape
Dim myrange As Range
Dim ws As Worksheet
Set ws = Worksheets(1)
Set myrange = ws.Range("c5:f8")
With myrange
    Set myshape = ws.Shapes.AddShape(msoShapeRectangle, _
    Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
Set myshape = Nothing
    Set myrange = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 删除指定的shape对象()
Dim myshape  As Shape
Dim ws As Worksheet
Set ws = Worksheets(1)
For Each myshape In ws.Shapes
    With myshape
        If .Type = msoAutoShape Then
            myshape.Delete
        End If
    End With
Next
Set ws = Nothing
End Sub

jsgj2023

Sub 将shape固定在指定的位置()
    With ActiveSheet.Shapes(1)
    .Top = ActiveSheet.Cells(1, 1).Top + 10
    .Left = ActiveSheet.Cells(1, 1).Left + 10
    End With
End Sub

jsgj2023

Sub 制作旋转的shape图形()
Dim myshape As Shape
Dim ws As Worksheet
Dim i As Long
Dim j As Long
Set ws = Worksheets(1)
With ws
    For Each myshape In .Shapes
        myshape.Delete
    Next
    Set myshape = .Shapes.AddShape(Type:=msoShape16pointStar, _
    Left:=120, Top:=80, Width:=80, Height:=80)
End With
With myshape
    For i = 1 To 3000 Step 5
        .Top = Sin(i * (3.1416 / 180)) * 100 + 100
        .Left = Cos(i * (3.1416 / 180)) * 100 + 100
        .Fill.ForeColor.RGB = i * 100
        For j = 1 To 10
            .IncrementRotation -2
            DoEvents
        Next
    Next
End With
End Sub

jsgj2023

Sub 遍历指定目录下的所有子文件夹和文件()
    Dim MyName, dic, did, i, t, f, tt, MyFileName
    t = Time
    Set dic = CreateObject("scripting.dictionary")
    Set did = CreateObject("scripting.dictionary")
    dic.Add ("F:\c.绩效薪酬\工资及收现计算\"), ""
    i = 0
    Do While i < dic.Count
        Ke = dic.keys
        MyName = Dir(Ke(i), vbDirectory)
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
                    dic.Add (Ke(i) & MyName & "\"), ""
                End If
            End If
            MyName = Dir
        Loop
        i = i + 1
    Loop
    did.Add ("文件清单"), ""
    For Each Ke In dic.keys
        MyFileName = Dir(Ke & "*.xls")
        Do While MyFileName <> ""
            did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.Delete
            f = True
            Exit For
        Else
            f = False
        End If
    Next
    If Not f Then
        Sheets.Add.Name = "XLS文件清单"
    End If
    Sheets("XLS文件清单").[A1].Resize(did.Count, 1) = WorksheetFunction.Transpose(did.keys)
    tt = Time - t
    MsgBox Minute(tt) & "分" & Second(tt) & "秒"
End Sub

jsgj2023

Sub CCS系统型号直接与BMS系统型号匹配()
Dim d  As Object, arr, x&, y&
Set d = CreateObject("scripting.dictionary")
With GetObject(ThisWorkbook.Path & "\BMS系统销售---2017年1月检测表合并.xlsx")
arr = .Sheets("合并结果").[a1].CurrentRegion
.Close False
End With
For x = 2 To UBound(arr)
    If Not d.exists(UCase(arr(x, 5))) Then
        d(UCase(arr(x, 5))) = arr(x, 4)
    End If
Next x
brr = Range("a1").CurrentRegion
For y = 2 To UBound(brr)
    If d.exists(UCase(brr(y, 22))) Then
        Cells(y, 25) = d(UCase(brr(y, 22)))
    End If
Next y
End Sub