VBA几个常用的模块

Option Explicit

'1把所有工作sheet的A1为选定状态

Public Sub ExcelManner()

Dim i

For i = ActiveWorkbook.Worksheets.Count To 1 Step -1

    If ActiveWorkbook.Worksheets(i).Visible = xlSheetVisible Then '隐藏除外
        ActiveWorkbook.Worksheets(i).Select
        ActiveWorkbook.Worksheets(i).Cells(1, 1).Select
    End If

Next i

ActiveWorkbook.Saved = True

ActiveWorkbook.Save

End Sub

'1把所有工作sheet的A1为选定状态 完了

'2把所有工作sheet的显示倍率都设置成当前sheet的显示倍率并保存

Public Sub AutoZoom()

Dim i

Dim Rate

Rate = ActiveWindow.Zoom

For i = ActiveWorkbook.Worksheets.Count To 1 Step -1

ActiveWorkbook.Worksheets(i).Select

ActiveWindow.Zoom = Rate

Next i

ActiveWorkbook.Saved = True

ActiveWorkbook.Save

End Sub

'2把所有工作sheet的显示倍率都设置成当前sheet的显示倍率保存 完了

'3在所选的单元格位置增加向下箭头

Public Sub ArrowAdd()

Dim addressCell

addressCell = Replace(ActiveCell.Address, "$", "")

Dim rng As Range: Set rng = Range(addressCell)

ActiveSheet.Shapes.AddShape(msoShapeDownArrow, rng.Left, rng.Top, 60, 30).Select '壓岦偒栴報

End Sub

'3在所选的单元格位置增加向下箭头 完了

'4在所选的单元格位置增加红色透明矩形

Public Sub wakuAdd()

Dim addressCell

addressCell = Replace(ActiveCell.Address, "$", "")

Dim rng As Range: Set rng = Range(addressCell)

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rng.Left, rng.Top, 60, 30)

.Line.ForeColor.RGB = RGB(255, 0, 0)

.Fill.ForeColor.RGB = RGB(255, 255, 255)

.Fill.Transparency = 1

End With

End Sub

'4在所选的单元格位置增加红色透明矩形 完了

'5在所选的单元格位置添加剪贴板中的图形

Public Sub screenshotAdd()

'缩放比例

Dim resize As Double

'图形间间隔的单元格行数

Dim spaceRow As Integer

Dim CB As Variant

Dim i As Long

Dim lastImg As Integer

Dim imgHeight As Double

Dim moveCell As Integer

CB = Application.ClipboardFormats

If CB(1) = True Then

MsgBox "剪贴板中为空", 48

Exit Sub

End If

For i = 1 To UBound(CB)

If CB(i) = xlClipboardFormatBitmap Then

ActiveSheet.Paste

lastImg = ActiveSheet.Shapes.Count

ActiveSheet.Shapes(lastImg).Select

If 0 <> resize Then

Selection.Height = Selection.Height * resize

Selection.Width = Selection.Width

End If

imgHeight = Selection.Height

If 0 <> resize Then

moveCell = imgHeight \ ActiveCell.RowHeight + spaceRow

Else

moveCell = imgHeight \ ActiveCell.RowHeight + 2

End If

ActiveCell.Offset(moveCell, 0).Activate

Exit For

End If

Next i

End Sub

'5在所选的单元格位置添加剪贴板中的图形 完了

'6合并單元格左居上部

Public Sub MergeLeft()

Dim starAddress

Dim endAddress

Dim rngAddress

Dim rng As Range

If Selection.Count > 1 Then

starAddress = Split(Selection.Address(), ":")(0)

Application.Volatile True

endAddress = Split(Selection.Address(), ":")(1)

rngAddress = Replace(starAddress, "$", "") & ":" & Replace(endAddress, "$", "")

Range(rngAddress).Merge

Range(Replace(starAddress, "$", "")).HorizontalAlignment = xlLeft

Range(Replace(starAddress, "$", "")).VerticalAlignment = xlTop

End If

End Sub

‘插入sheet,

‘条件：当前单元格不为空，当前单元格文字为新插入sheet的名称

Sub CreateNewWorksheet()
' Check if a cell is selected
    If Not Selection Is Nothing Then
        ' Check if the selected cell is not empty
        Dim LinkName As String
       LinkName = ActiveSheet.Name
        Dim LinkAddress As String
        LinkAddress = Selection.Offset(0, 65).Address
        
        Dim currentIndex As Integer
            currentIndex = ActiveSheet.Index
        If Not IsEmpty(Selection.Value) Then
            ' Get the content of the selected cell
            Dim cellContent As String
            cellContent = Selection.Value
            
            ' Create a new worksheet
            Dim newWorksheet As Worksheet
            
            
            Set newWorksheet = ActiveWorkbook.Sheets.Add(After:=Sheets(currentIndex))
            On Error Resume Next
            
            newWorksheet.Name = cellContent
            
           If Err.Number <> 0 Then '
                MsgBox "An error occurred: " & Err.Description
                 newWorksheet.Name = cellContent & "(1)"
                Err.Clear '
               
            End If
           
            ' Add a hyperlink to cell A1 in the new worksheet
            ActiveSheet.Hyperlinks.Add Anchor:=newWorksheet.Cells(1, 1), Address:="", _
                SubAddress:=LinkName & "!" & LinkAddress, TextToDisplay:=LinkName & "!" & LinkAddress
        End If
    End If
End Sub