Excel宏常用代码

使用Dim语句

Dim a as integer '声明a为整型变量

Dim a '声明a为变体变量

Dim a as string '声明a为字符串变量

Dim a as currency ,b as currency ,c as currency '声明a,b,c为货币变量

......

声明变量可以是：Byte、Boolean、Integer、Long、Currency、Single、Double、Decimal（当前不支持）、Date、String（只限变长字符串）、String * length（定长字符串）、Object、Variant、用户定义类型或对象类型。

强制声明变量

Option Explicit

说明：该语句必在任何过程之前出现在模块中。

声明常数

用来代替文字值。

Const

' 常数的默认状态是 Private。

Const My = 456

' 声明 Public 常数。

Public Const MyString = "HELP"

' 声明 Private Integer 常数。

Private Const MyInt As Integer = 5

' 在同一行里声明多个常数。

Const MyStr = "Hello

。

Dim my As Worksheet

For Each my In Worksheets

my.PrintPreview

Next my

得到当前单元格的地址

msgbox ActiveCell.Address

得到当前日期及时间

msgbox date & chr(13) & time

保护工作簿

ActiveSheet.Protect

取消保护工作簿

ActiveSheet.Unprotect

给活动工作表改名为 "liu"

ActiveSheet.Name = "liu"

打开一个应用程序

AppActivate (Shell("C:\\WINDOWS\\CALC.EXE"))

增加一个工作表

Worksheets.Add

删除活动工作表

activesheet.delete

打开一个工作簿文件

Workbooks.Open FileName:="C:\\My Documents\\Book2.xls"

关闭活动窗口

ActiveWindow.Close

单元格格式

选定单元格左对齐

Selection.HorizontalAlignment = xlLeft

选定单元格居中

Selection.HorizontalAlignment = xlCenter

选定单元格右对齐

Selection.HorizontalAlignment = xlRight

选定单元格为百分号风格

Selection.Style = "Percent"

选定单元格字体为粗体

Selection.Font.Bold = True

选定单元格字体为斜体

Selection.Font.Italic = True

选定单元格字体为宋体20号字

With Selection.Font

.Name = "宋体"

.Size = 20

End With

With 语句

With 对象

.描述

End With

清除单元格

ActiveCell.Clear '删除所有文字、批注、格式

返回选定区域的行数

MsgBox Selection.Rows.Count

返回选定区域的列数

MsgBox Selection.Columns.Count

返回选定区域的地址

Selection.Address

忽略所有的错误

ON ERROR RESUME NEXT

遇错跳转

on error goto err_handle

'中间的其他代码

err_handle: ' 标签

'跳转后的代码

删除一个文件

kill "c:\\1.txt"

定制自己的状态栏

Application.StatusBar = "现在时刻: " & Time

恢复自己的状态栏

Application.StatusBar = false

用代码执行一个宏

Application.Run macro:="text"

滚动窗口到a1的位置

ActiveWindow.ScrollRow = 1

ActiveWindow.ScrollColumn = 1

定制系统日期

Dim MyDate, MyDay

MyDate = #12/12/69#

MyDay = Day(MyDate)

返回当天的时间

Dim MyDate, MyYear

MyDate = Date

MyYear = Year(MyDate)

MsgBox MyYear

inputbox<输入框>

XX=InputBox ("Enter number of months to add")

得到一个文件名

Dim kk As String

kk = Application.GetOpenFilename("EXCEL (*.XLS), *.XLS

of workbook structure / windows passwords and for multiple passwords

'

' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)

' Modified 2003-Apr-04 by JEM: All msgs to constants, and

' eliminate one Exit Sub (Version 1.1.1)

' Reveals hashed passwords NOT original passwords

Const DBLSPACE As String = vbNewLine & vbNewLine

Const AUTHORS As String = DBLSPACE & vbNewLine & _

"Adapted from Bob McCormick base code by" & _

"Norman Harker and JE McGimpsey"

Const HEADER As String = "AllInternalPasswords User Message"

Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"

Const REPBACK As String = DBLSPACE & "Please report failure " & _

"to the microsoft.public.excel.programming newsgroup."

Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _

"now be free of all password protection, so make sure you:" & _

DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _

DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _

DBLSPACE & "Also, remember that the password was " & _

"put there for a reason. Don't stuff up crucial formulas " & _

"or data." & DBLSPACE & "Access and use of some data " & _

"may be an offense. If in doubt, don't."

Const MSGNOPWORDS1 As String = "There were no passwords on " & _

"sheets, or workbook structure or windows." & AUTHORS & VERSION

Const MSGNOPWORDS2 As String = "There was no protection to " & _

"workbook structure or windows." & DBLSPACE & _

"Proceeding to unprotect sheets." & AUTHORS & VERSION

Const MSGTAKETIME As String = "After pressing OK button this " & _

"will take some time." & DBLSPACE & "Amount of time " & _

"depends on how many different passwords, the " & _

"passwords, and your computer's specification." & DBLSPACE & _

"Just be patient! Make me a coffee!" & AUTHORS & VERSION

Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _

"Structure or Windows Password set." & DBLSPACE & _

"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _

"Note it down for potential future use in other workbooks by " & _

"the same person who set this password." & DBLSPACE & _

"Now to check and clear other passwords." & AUTHORS & VERSION

Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _

"password set." & DBLSPACE & "The password found was: " & _

DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _

"future use in other workbooks by same person who " & _

"set this password." & DBLSPACE & "Now to check and clear " & _

"other passwords." & AUTHORS & VERSION

Const MSGONLYONE As String = "Only structure / windows " & _

"protected with the password that was just found." & _

ALLCLEAR & AUTHORS & VERSION & REPBACK

Dim w1 As Worksheet, w2 As Worksheet

Dim i As Integer, j As Integer, k As Integer, l As Integer

Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer

Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer

Dim PWord1 As String

Dim ShTag As Boolean, WinTag As Boolean

Application

.ScreenUpdating = False

With ActiveWorkbook

WinTag = .ProtectStructure Or .ProtectWindows

End With

ShTag = False

For Each w1 In Worksheets

ShTag = ShTag Or w1.ProtectContents

Next w1

If Not ShTag And Not WinTag Then

MsgBox MSGNOPWORDS1, vbInformation, HEADER

Exit Sub

End If

MsgBox MSGTAKETIME, vbInformation, HEADER

If Not WinTag Then

MsgBox MSGNOPWORDS2, vbInformation, HEADER

Else

On Error Resume Next

Do 'dummy do loop

For i = 65 To 66: For j = 65 To 66: For k = 65 To 66

For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66

For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66

For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

With ActiveWorkbook

.Unprotect Chr(i) & Chr(j) & Chr(k) & _

Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _

Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If .ProtectStructure = False And _

.ProtectWindows = False Then

PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _

Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _

Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

MsgBox Application.Substitute(MSGPWORDFOUND1, _

"$$

班工时登记表.XLS>,要求使用SQL技术将表里的数据导入所有数据(不含表头)到<智能工时统计系统.xls>里的"自愿加班"表格里.

Private Sub CommandButton1_Click()

Sheets("自愿加班").Activate

Set xx = CreateObject("adodb.connection")

With xx

.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.Path & "/" & "加班工时数据/" & "自愿加班工时登记表.XLS"

Sql = "select * from [sheet1$a3:h65536] "

[A4].CopyFromRecordset .Execute(Sql)

End With

xx.Close

Set xx = Nothing

End Sub

***********************************************************************************************************************

我用EXCEL中的VBA编了一个自动获取银行汇率的程序.希望每天8:30分后就每分钟刷新一次, 获得了变化的汇率后就自动放慢刷新频率,每2小时刷新一次.如何才能在VBA中改变这个刷新频率?请高手指教!

问题补充：获取银行汇率是采用导入外部数据的方式.在工作表页面上数据区点右键,选中"数据区域属性"里面有个刷新频率.我是想在VBA的代码中根据条件改变这个刷新频率的数值.如何编写这段代码?

问题已解决:

Sub refresh()

Dim sht As Worksheet 'sht 为excel工作表对象变量，指向某一工作表

Set sht = ThisWorkbook.Worksheets("sheet1") '把sht指向当前工作簿的sheet1工作表

Sheets("Sheet1").Select '必须先选定刷新的页面

Range("B6").Select '还要选定一个有被刷新的单元格

With Selection.QueryTable

.RefreshPeriod = 5 '设定5分钟刷新一次.如果为 0 停止刷新

End With

End Sub

记得把备注栏单元格取消合并

**********************************************************************************************************************

刷新并save

ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh

ActiveWorkbook.Save

********************************************************************************************************************

如果只刷新数据透视表,而不刷新同一透视表缓存的其它透视表:

sheet1.pivottables("数据透视表1").refreshtable

Activeworkbook.save

有关刷新数据透视表问题

附件为 “夜半传说“兄之前指教的一个数据透视表。在实用中，由于透视表所指数据，在设定的程式下会随时改变，因此，我想在程式中加插一段代码，用于刷新数据透视表，使运行程式时数据表也随之更新，小弟试录了一个宏，把代码修改如下，但无法执行，不知应如何修改才对呢？请“传说“兄指教。

With Sheets("sheet11")

ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh

End With

試試

Worksheets("Sheet11").PivotTables(1).RefreshTable

*********************************************************************************************************************

刷新并返回

Sub 按钮1_单

击()

Sheets("buy").Select

Range("A3").Select

ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh

Sheets("Market别分析").Select

End Sub

**************************************************************************************************

Sub 刷新()

Sheets("buy").Select

ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh

Sheets("Inch").Select

ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh

ActiveWindow.ScrollWorkbookTabs Sheets:=1

Sheets("Market别分析").Select

End Sub

.PivotCache.BackgroundQuery = True