VBA几个常用的模块

Option Explicit

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

Public Sub ExcelManner()

Dim i

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

ActiveWorkbook.Worksheets(i).Select

ActiveWorkbook.Worksheets(i).Cells(1, 1).Select

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