图片切换
Sub 显示开或关()
If ActiveSheet.Shapes("Picture 2").Visible = True Then
ActiveSheet.Shapes("Picture 1").Visible = True
ActiveSheet.Shapes("Picture 2").Visible = False
Else
ActiveSheet.Shapes("Picture 2").Visible = True
ActiveSheet.Shapes("Picture 1").Visible = False
End If
End Sub
当前单元格输入数字自动分解
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 Then Exit Sub
If Len(Target(1, 1)) > 1 Then
Dim oJs As Object
Set oJs = CreateObject("ScriptControl"): oJs.Language = "JScript"
Target(1, 2).Resize(1, 254).ClearContents
Target.Resize(1, Len(Target)) = Split(oJs.eval("'" & Target & "'.match(/./g);"), ",") End If
End Sub
word批量修改图片大小——固定长宽
Sub setpicsize() '设置图片大小
Dim n'图片个数
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为400px ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度300px
Next n
End Sub
批量修改图片大小——按比例缩放篇
Sub setpicsize() '设置图片大小
Dim n'图片个数
Dim picwidth
Dim picheight
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
picheight = ActiveDocument.InlineShapes(n).Height
picwidth = ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height = picheight * 1.1 '设置高度为1.1倍ActiveDocument.InlineShapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍Next n
For n = 1 To
ActiveDocument.Shapes.Count 'Shapes类型图片
picheight = ActiveDocument.Shapes(n).Height
picwidth = ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height = picheight * 1.1 '设置高度为1.1倍ActiveDocument.Shapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
Next n
End Sub
批量给图片加边框
Dim i As Integerresize函数vba
For i = 1 To ActiveDocument.InlineShapes.Count
With ActiveDocument.InlineShapes(i)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth100pt
.
DefaultBorderColor = wdColorAutomatic
End With
Next i
锁定文件名
Private Sub Workbook_Open()
If ThisWorkbook.Name <> "三八节.xls" Then
Application.DisplayAlerts = False
Application.Quit
End If
End Sub
将数值转换为文本
[程序扩展] 可以将程序代码1和程序代码2略加改动，将一个字符附加到所选单元格的开头。如将cell.Value = "'" & cell.Value换成cell.Value=”I”&cell.Value，则在所选单元格开头添加字符“I”，即可统一单元格开始形式。
[程序代码1]
Sub 数值转换为文本1() '通过添加'号
Dim cell As Range
For Each cell In Selection
If Not cell.HasFormula Then
If Not IsEmpty(cell) Then
cell.Value = "'" & cell.Value
End If
End If
Next
End Sub
[程序代码2]
Sub 数值转换成文本2() '只对数字单元格进行操作
Dim cell As Range
For Each cell In Selection
If Not cell.HasFormula Then
If Not IsEmpty(cell) Then
If IsNumeric(cell) Then
cell.Value = "'" & cell.Value '可根据需要变换字符
End If
End If
End If
Next
End Sub
[程序代码3]
Sub 数值转换为文本3() '通过格式
Dim cell As Range
For Each cell In Selection
If Not cell.HasFormula Then
If Not IsEmpty(cell) Then
Selection.NumberFormatLocal = "@"
End If
End If
Next
End Sub
关闭并保存所有工作簿
Option Explicit
Sub CloseAllWorkbooks()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Name<>ThisWorkbook.Name Then
Book.Close savechanges:=True
End If
Next Book
ThisWorkbook.Close savechanges:=True
End Sub
关闭工作簿并将它彻底删除
Option Explicit
Sub KillMe()
With ThisWorkbook
.Saved = True
.ChangeFileAccess
Mode:=xlReadOnly
Kill .FullName .Close False
End With
End Sub
A列输出排列组合
Sub pailie()
Dim s As String, x() As String
Dim starttime As Single, endtime As Single
Dim i As Long, j As Integer, k As Integer, Num As Long, n As Integer Dim ALL(), TEMP1 As Long, TEMP2 As Long, arr() As String
s = InputBox("请输入不重复的字母或数字")
n = Len(s) '元素个数
ReDim x(n - 1)
For i = 1 To n
x(i - 1) = Mid(s, i, 1)
Next
starttime = Timer '开始计时
Num = 1
For i = 1 To n
Num = Num * i  '递归计算n！
Next
ReDim arr(1 To Num, 1 To 1)
For i = 1 To Num
ReDim ALL(1 To n) '初始化数组all
ALL(1) = x(0)
TEMP1 = i
For j = 2 To n
TEMP2 = TEMP1 Mod j
TEMP1 = TEMP1 \ j
If TEMP2 = 0 Then
ALL(j) = x(j - 1) 'temp2为0则放在最后
Else
For k = j To TEMP2 + 1 Step -1
ALL(k) = ALL(k - 1)  ' temp2之后的元素后移一位
Next
ALL(TEMP2) = x(j - 1) 'temp2不为0 则置于第temp2个元素前
End If
Next
arr(i, 1) = Join(ALL, "") '输出
Next
endtime = Timer
Application.ScreenUpdating = False
Range("a1").Resize(Num, 1) = arr
Application.ScreenUpdating = True
MsgBox "共" & Num & " 种排列！用时" & endtime - starttime & " 秒！"
End Sub
同薄汇总工作表
Sub mysub()
Application.ScreenUpdating = False
Dim sh As Worksheet, aa As Long, bb As Long, cc As Long, dd As Long
dd = Sheets("汇总").[IV1].End(1).Column
Sheets("汇总").Range(Cells(2, 2), Cells(65536, dd)).ClearContents
For Each sh In Worksheets
If sh.Name <> "汇总" Then
bb = Sheets("汇总").[b65536].End(xlUp).Row + 1
aa = sh.[b65536].End(xlUp).Row
cc = sh.[IV1].End(1).Column
sh.Range(sh.Cells(2, 2), sh.Cells(aa, cc)).Copy
Sheets("汇总").Cells(bb, 2).PasteSpecial xlPasteValues
End If
Next sh
Application.ScreenUpdating = True
End Sub
异薄SHEET1汇总
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i&, LastRow&, Path$, FileName$, TWB$, WB As Workbook
Path = ThisWorkbook.Path & "\"
FileName = Dir(Path & "*.xls")
TWB = ThisWorkbook.Name
Range("A1:X65536").ClearContents
Do While Len(FileName)
If FileName <> TWB Then
Set WB = Workbooks.Open(Path & FileName)
With WB.Worksheets(1)
LastRow = .Range("A65536").End(xlUp).Row
If LastRow > 1 Then
.Range("A8:x8").Copy
ThisWorkbook.Sheets("汇总").Range("A65536").End(xlUp)(2).PasteSpecial Paste:=xlValue
End If
End With
Application.CutCopyMode = False
WB.Close True
End If
FileName = Dir()
Loop
Range("A1").Select
Set WB = Nothing
Application.ScreenUpdating = True
End Sub
异薄汇总工作表
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i&, LastRow&, Path$, FileName$, TWB$, WS As Worksheet, WB As Workbook
Path = ThisWorkbook.Path & "\"
FileName = Dir(Path & "*.xls")
TWB = ThisWorkbook.Name
Range("A1:X65536").ClearContents
Do While Len(FileName)
If FileName <> TWB Then
Set WB = Workbooks.Open(Path & FileName)
For Each WS In WB.Worksheets
LastRow = WS.Range("A65536").End(xlUp).Row
If LastRow > 1 Then
WS.Range("A8:x" & LastRow).Copy '复制A8：X列&最后有数据的列
ThisWorkbook.Sheets("汇总").Range("A65536").End(xlUp)(2).PasteSpecial Paste:=xlValue '粘贴到“汇总”表，从下往上数有数据的列的下一列
End If
Next
Application.CutCopyMode = False
WB.Close True
End If
FileName = Dir()
Loop
Range("A1").Select
Set WB = Nothing
Application.ScreenUpdating = True
End Sub
调用实例
Application.Dialogs(1).Show是调用打开对话框
Application.Dialogs(5或145).Show是调用另存为对话框，
Application.Dialogs(6).Show是删除文档
Application.Dialogs(7).Show是页面设置
Application.Dialogs(8).Show是打印对话框
Application.Dialogs(9).Show是选择打印机对话框
Application.Dialogs(12).Show是重排窗口设置对话框
Application.Dialogs(17).Show宏对话框
Application.Dialogs(23).Show设置打印标题

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。