VBA各种超链接代码

合集下载

VBA函数大全

返回参数的绝对值, 其类型和参数相同。

Array函数返回一个包含数组的Variant。

Asc函数返回一个Integer, 代表字符串中首字母的字符代码。

Atn函数返回一个Double, 指定一个数的反正切值。

CallByName函数执行一个对象的方法, 或者设置或返回一个对象的属性。

Choose函数从参数列表中选择并返回一个值。

Chr函数返回String, 其中包含有与指定的字符代码相关的字符。

返回一个Double, 指定一个角的余弦值。

CreateObject函数创建并返回一个对ActiveX对象的引用。

CurDir函数返回一个Variant(String), 用来代表当前的路径。

CVErr函数返回Error子类型的Variant, 其中包含指定的错误号。

Date函数返回包含系统日期的Variant(Date)。

DateAdd函数返回包含一个日期的Variant(Date), 这一日期还加上了一段时间间隔。

DateDiff函数返回Variant(Long)的值, 表示两个指定日期间的时间间隔数目。

DatePart函数返回一个包含已知日期的指定时间部分的Variant(Integer)。

DateSerial函数返回包含指定的年、月、日的Variant(Date)。

DateValue函数返回一个Variant(Date)。

Day函数返回一个Variant(Integer), 其值为1到31之间的整数, 表示一个月中的某一日。

DDB函数返回一个Double, 指定一笔资产在一特定期间内的折旧。

可使用双下落收复平衡方法或其它指定的方法进行计算。

Dir函数返回一个String, 用以表示一个文件名、目录名或文件夹名称, 它必须与指定的模式或文件属性、或磁盘卷标相匹配。

DoEvents函数转让控制权, 以便让操作系统处理其它的事件。

Environ函数返回String, 它关连于一个操作系统环境变量。

在Macintosh中不可用EOF函数返回一个Integer, 它包含Boolean值True, 表明已经到达为Random或顺序Input打开的文件的结尾。

VBA代码汇总

VBA代码汇总Sub 批量超链接word文档()' 宏1 宏' 超链接Dim p$, f$, i As Integeri = 1p = "C:\Users\Administrator\Desktop\国创撰写\" & ""f = Dir(p & "*.docx") '取得第一个pdf文件名Do While f <> "" ' 循环语句ThisWorkbook.ActivateSheets(1).Cells(i, 1).Value = f 'Range("a1").Value = p & fActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=p & f, _TextToDisplay:=f'MsgBox p & f 显示路径加文件名f = Dir '第二个文件名i = i + 1LoopEnd SubPrivate Sub CommandButton1_Click() 随机选择器Dim a, b, c, d As StringDim shu As IntegerDim arr(1 To 4)shu = Int((4 * Rnd) + 1)arr(1) = TextBox1.Valuearr(2) = TextBox2.Valuearr(3) = TextBox3.Valuearr(4) = TextBox4.ValueMsgBox "excel推荐你今天应该吃" & arr(shu)End SubPrivate Sub CommandButton2_Click() Unload MeEnd SubSub 批量新建指定名称工作簿() Application.DisplayAlerts = FalseFor i = 1 To 54 ' 个数减一Dim Rng As StringDim abc As RangeDim wb As WorkbookDim wb1 As WorkbookSet wb1 = ThisWorkbookWith ActiveCellRng = .ValueSet abc = .Offset(1, 0)End WithDim a As RangeDim b As Longb = 0For Each a In Range("E:E")If a.Value = Rng Thenb = b + 1End IfNextActiveCell.Offset(b, 0).EntireRow.Select Selection.Insert Shift:=xlDown Selection.Insert Shift:=xlDownabc.SelectRange("A1").EntireRow.Copy abc.Offset(b, -4) Set wb = Workbooks.Add'Filename:=ThisWorkbook.Path & Application.PathSeparator & Rng & ".xls"wb1.Sheets(1).Activateabc.CurrentRegion.Copywb.Sheets(1).Activatewb.Sheets(1).Pastewb.SaveAs "C:\Users\Administrator\Desktop\团队人员统计\" & Rng & ".xlsx" '之前忘了保存了wb.Closewb1.Sheets(1).Activateabc.Offset(b + 1, 0).SelectNextApplication.DisplayAlerts = TrueEnd SubSub 输入输出()Dim abc As Stringabc = InputBox("你想问什么", "这是一个标题")Call MsgBox("房主你最帅^ ^", 0, "这是标题")'加了括号一定要返回值，或者加call'Dim wb As Workbook' Set wb = Workbooks.Add' wb.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "woshi.xls" '搞定名称啦！Sub 自动分组打印6_Click()For i = 1 To 35Dim Rng As StringDim abc As RangeWith ActiveCellRng = .ValueSet abc = .Offset(1, 0)End WithDim a As RangeDim b As Integerb = 0For Each a In Range("A:A")If a.Value = Rng Thenb = b + 1End IfNext' MsgBox bActiveCell.Offset(b, 0).EntireRow.SelectSelection.Insert Shift:=xlDownSelection.Insert Shift:=xlDownabc.SelectWorksheets("团队出勤").PageSetup.PrintArea = abc.CurrentRegion.AddressWorksheets("团队出勤").PrintOutRange("a1").EntireRow.Copy abc.Offset(b, 0)abc.Offset(b + 1, 0).SelectNextEnd SubPublic Sub多个工作表复制汇总()Dim p$, f$, z$, i As IntegerDim wb As WorksheetDim wb1 As WorkbookDim rng As RangeApplication.ScreenUpdating = FalseSet wb = ThisWorkbook.Worksheets(1)' p = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & ""f = Dir(ThisWorkbook.Path & "\*.xls") '取得第一个excel文件名Do While f <> "" ' 循环语句Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) ' ‘Set wb1 = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & f z = ThisWorkbook.Path & "\" & fSet wb1 = GetObject(z)wb1.Sheets(2).ActivateColumns("Q:Q").SelectSelection.AutoFilter '筛选已验证过没问题ActiveSheet.Range("Q:Q").AutoFilter Field:=1, Criteria1:="发明申请"Rows("2:2").SelectSelection.Insert Shift:=xlDownRange("a3").CurrentRegion.Copy rngwb1.Close False'wb.Activate' Set rng = wb.Worksheets(1).Range("A1048576").End(xlUp).Offset(1, 0) ' rng.PasteSpecial Paste:=xlPasteValues'Range("a1").Value = p & f'MsgBox p & f 显示路径加文件名f = Dir '第二个文件名LoopApplication.ScreenUpdating = TrueEnd SubSub 股票分类建立工作表()Application.DisplayAlerts = FalseDim Rng As StringDim abc As RangeDim b As IntegerDim a As RangeDim sht As WorksheetRng = Worksheets("沪深300成分股10年").Range("b2").Value Set abc = Worksheets("沪深300成分股10年").Range("b2") Do While Rng <> ""b = 0For Each a In Range("b:b")If a.Value = Rng Thenb = b + 1End IfNextWorksheets("沪深300成分股10年").Activateabc.Offset(b, 0).EntireRow.SelectSelection.Insert Shift:=xlDownSet sht = Worksheets.Add/doc/a711863622.html, = Rng Worksheets("沪深300成分股10年").Activateabc.CurrentRegion.Copy sht.Range("a1")Set abc = abc.Offset(b + 1, 0)Rng = abc.ValueLoopEnd SubSub 遍历工作表求偏度峰度For Each sheet In Sheetssheet.SelectActiveSheet.Range("F1").SelectActiveCell.FormulaR1C1 = "=LN(RC[-2]/RC[-1])"Set rng = ActiveSheet.Range("A1048576").End(xlUp)a = rng.RowActiveSheet.Range("F2").SelectActiveCell.FormulaR1C1 = "=LN(RC[-2]/R[-1]C[-2])"ActiveSheet.Range("F2").SelectSelection.AutoFill Destination:=Range("F2:F" & a)ActiveSheet.Range("F2:F" & a).SelectActiveSheet.Range("G1").SelectActiveCell.FormulaR1C1 = "=KURT(C[-1])"ActiveSheet.Range("H1").SelectActiveCell.FormulaR1C1 = "=SKEW(C[-2])"NextEnd SubSub 求单只股票每一年风度偏度()'Sub 每年()'' 每年宏Dim rng, rng1, rng2 As RangeDim a, c, e, d As StringDim sheet As WorksheetDim b, i, f As LongApplication.ScreenUpdating = falseFor Each sheet In Sheetssheet.Select'选中活动工作表‘k= ActiveSheet.Range("A1").CurrentRegion.Rows.Count ‘ 取得最后一行的行号k 为longSet rng = ActiveSheet.Range("A1048576").End(xlUp) '获得最后一个非空单元格a = rng.Row '非空单元格的行号ActiveSheet.Range("j1").SelectActiveCell.FormulaR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本Range("J1").SelectSelection.AutoFill Destination:=Range("J1:J" & a) '自动填充所有行Set rng1 = ActiveSheet.Range("j1")i = 1Do While rng1 <> ""c = rng1.Rowb = 0For Each rng2 In Range("j:j")If rng2.Value = rng1.value Thenb = b + 1End IfNext '获得每一年的个数d = rng1.Offset(b - 1, 0).Rowe = rng1.ValueActiveSheet.Cells(i, 11).Value = eActiveSheet.Cells(i, 12).Value = Application.WorksheetFunction.Kurt(sheet.Range("F" & c & ":F" & d))ActiveSheet.Cells(i, 13).Value = Application.WorksheetFunction.Skew(sheet.Range("F" & c & ":F" & d)) '计算i = i + 1Set rng1 = rng1.Offset(b, 0)LoopnextApplication.ScreenUpdating = True-探戈写的代码：Sub test2()Dim Filename As String, wb As Workbook, Erow As Long, fn As String, bj As Variant, i As Long, k As Long, j As Long, l As Long Filename = Dir(ThisWorkbook.Path & "\*.xls")Do While Filename <> ""If Filename <> /doc/a711863622.html, Thenfn = ThisWorkbook.Path & "\" & FilenameWorkbooks.Open (fn)With ActiveWorkbook.Worksheets(1)Cells(65536, "A").End(xlUp).EntireRow.DeleteErow = Cells(65536, "C").End(xlUp).RowCells(3, "F").FormulaR1C1 = "=Year(RC[-3])"Cells(3, "F").AutoFill Destination:=Range(Cells(3, "F"), Cells(Erow, "F"))Cells(1, "G") = "年份"Cells(1, "H") = "峰度"Cells(1, "I") = "偏度"i = 3l = 3bj = Cells(i, "F").Valuek = 2007j = 3Do While k <> 2018Do While bj = kbj = Cells(i, "F").Valuei = i + 1LoopCells(j, "H").Formula = "=KURT(R" & l & "C5:R" & i & "C5)"Cells(j, "I").Formula = "=SKEW(R" & l & "C5:R" & i & "C5)"Cells(j, "G").Value = kl = i + 1k = k + 1j = j + 1LoopEnd WithActiveWorkbook.Close savechanges:=TrueEnd IfFilename = DirLoopEnd Sub使用cells.formula 调用工作表函数Cells(1, 1).Formula = "=sum（d" & l & ":d3) "Sub 计算个股（单个工作簿工作表）的收益率和偏度峰度a()'Sub 计算偏度峰度a()'' 每年宏Dim rng, rng1, rng2, rng3 As RangeDim a, c, e, d As StringDim sheet As WorksheetDim b, i, f, k As LongDim filename, fn As Stringfilename = Dir(ThisWorkbook.Path & "\*.xls")Application.ScreenUpdating = FalseDo While filename <> ""If filename <> /doc/a711863622.html, Thenfn = ThisWorkbook.Path & "\" & filenameWorkbooks.Open (fn)ActiveWorkbook.Worksheets(1).SelectActiveSheet.Range("g2").Value = "长期收益率"ActiveSheet.Range("h2").Value = "长期峰度"ActiveSheet.Range("i2").Value = "长期偏度"ActiveSheet.Range("l2").Value = "每年收益率"ActiveSheet.Range("m2").Value = "每年峰度"ActiveSheet.Range("n2").Value = "每年偏度"ActiveSheet.Range("e3").SelectActiveCell.FormulaR1C1 = "=LN(RC[-1]/R[-1]C[-1])"k = ActiveSheet.Range("A1").CurrentRegion.Rows.CountActiveSheet.Range("e3").SelectSelection.AutoFill Destination:=Range("e3:e" & k)ActiveSheet.Cells(3, 8).Formula = "=KURT（e3:e" & k & ") " '算十年ActiveSheet.Cells(3, 9).Formula = "=skew(e3：e" & k & ") "ActiveSheet.Cells(3, 7).Formula = "=d" & k & "/d2 -1 "'选中活动工作表'非空单元格的行号ActiveSheet.Range("j3").SelectActiveCell.FormulaR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本Range("J3").SelectSelection.AutoFill Destination:=Range("J3:J" & k) '自动填充所有行Set rng1 = ActiveSheet.Range("j3")i = 3Do While rng1 <> ""c = rng1.Rowb = 0For Each rng2 In Range("j:j")If rng2.Value = rng1.Value Thenb = b + 1Next '获得每一年的个数d = rng1.Offset(b - 1, 0).Rowe = rng1.ValueActiveSheet.Cells(i, 11).Value = eActiveSheet.Cells(i, 13).Formula = "=KURT（e" & c & ":e" & d & ") "ActiveSheet.Cells(i, 14).Formula = "=skew（e" & c & ":e" & d & ") "ActiveSheet.Cells(i, 12).Formula = "=d" & d & "/d" & c & "-1 "i = i + 1Set rng1 = rng1.Offset(b, 0)LoopActiveWorkbook.Close savechanges:=TrueEnd Iffilename = DirLoopApplication.ScreenUpdating = TrueEnd Sub------------批量总表Dim a, c, e, d As StringDim sheet As WorksheetDim b, i, f, k As LongDim filename, fn As Stringfilename = Dir(ThisWorkbook.Path & "\*.xls")Application.ScreenUpdating = FalseSet rng1 = ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)Do While filename <> ""If filename <> /doc/a711863622.html, Thenfn = ThisWorkbook.Path & "\" & filenameWorkbooks.Open (fn)ActiveWorkbook.Worksheets(1).SelectWith ActiveWorkbook.Worksheets(1).Range("b2").CopyThisWorkbook.Sheets(1).Cells(i, 1).PasteSpecial xlPasteValues.Range("g3:i3").CopyThisWorkbook.Sheets(1).Cells(i, 2).PasteSpecial xlPasteValuesEnd WithActiveWorkbook.Close savechanges:=TrueEnd Ifi= i+1filename = DirLoopApplication.ScreenUpdating = TrueEnd SubPublic Sub 汇总工作簿的不同工作表()Dim f$, z$, i As Long '定义变量Dim wb As WorksheetDim wb1 As WorkbookDim rng As RangeApplication.ScreenUpdating = False ’关闭屏幕更新，加快运行速度Set wb = ThisWorkbook.Worksheets(1) '定义代码所在工作簿的变量f = Dir(ThisWorkbook.Path & "\*.xls") '取得所在文件夹的第一个excel 文件名Do While f <> "" ' 循环语句If f <> /doc/a711863622.html, Then ’判断该文件是否是代码所在工作簿Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) '取得所要汇总的工作簿的A列第一个非空单元格z = ThisWorkbook.Path & "\" & fSet wb1 = Workbooks.Open(z) ’打开其他的工作簿wb1.Sheets(1).Range("B6").CurrentRegion.Copy rng '开始复制其他工作簿的内容到指定位置。

VBA为EXCEL批量加入超链接

VBA为EXCEL批量加入超链接Sub 链接(path As String)On Error Resume NextDim myPath As StringDim myFileName As StringDim myWorksheetName As StringDim sName As StringDim addr As StringmyWorksheetName = /doc/a5609408.html, '选择活动工作表myPath = path & "\" '目标文件夹myFileName = Dir(myPath, 0)Dim file() As StringDim n, k, xx = 2n = 1: k = 1ReDim file(1 T o n)'file(1) = myPathDo Until n > k '遍历文件夹和子文件夹myFileName = Dir(file(n), vbDirectory)Do Until myFileName = ""If InStr(myFileName, ".") = 0 Thenk = k + 1ReDim Preserve file(1 To k)file(k) = file(n) & myFileName & "\"End IfmyFileName = DirLoopn = n + 1LoopFor n = 1 To k '添加链接myFileName = Dir(file(n) & "*.*")Do Until myFileName = ""addr = file(n) & myFileNamesName = Left(myFileName, Application.Find(".", myFileName) - 1)Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=addr, TextToDisplay:=sName'Range("B" & x).Value = myWorksheetNameRange("D" & x).Value = Format(CreateObject("scripting.filesystemobject").getfile(addr). DateCreated, "yyyy-mm-dd hh:nn") '文件创建时间x = x + 1myFileName = DirLoopNext'按时间排序降序Columns("D:D").SelectActiveWorkbook.Worksheets(myWorksheetName).Sort.Sort Fields.ClearActiveWorkbook.Worksheets(myWorksheetName).Sort.Sort Fields.Add Key:=Range("D1"), SortOn _:=xlSortOnValues, Order:=xlDescending,DataOption:=xlSortNormalWith ActiveWorkbook.Worksheets(myWorksheetName).Sort .SetRange Range("A2:D" & x).Header = xlNo.MatchCase = False.Orientation = xlTopToBottom.SortMethod = xlPinYin.ApplyEnd WithEnd Sub。

vba连接数据代码（excelaccesssqlserver）

vba连接数据代码（excelaccesssqlserver）Sub excel连接数据库()Dim Con As New ADODB.ConnectionDim strCon As StringDim rs As ADODB.Recordset '设置记录集Dim i, tt = TimerstrCon = " Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source= D:\平台\报表\账户流水.xlsx" & _";Extended Properties=""Excel 12.0;HDR=True"";"strSQL = "select * from [账户流水$]"Con.Open strConSet rs = Con.Execute(strSQL)For i = 0 To rs.Fields.Count - 1 '逐个字段Cells(3, i + 3) = rs.Fields(i).Name '取字段名字头放置在cell(3,3) Next iRange("c4").CopyFromRecordset rsrs.CloseCon.CloseSet rs = NothingSet Con = NothingMsgBox "提取完毕" & "耗时" & Round(Timer - t, 4) & "秒" End SubSub access连接并查询()Dim Con As New ADODB.ConnectionDim strConn As StringDim rs As ADODB.Recordset '设置记录集Dim i, tt = TimerstrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=C:\Users\Administrator\Desktop\test.accdb"strSQL = "select * from 账户流水"Con.Open strConnSet rs = Con.Execute(strSQL)For i = 0 To rs.Fields.Count - 1 '逐个字段Cells(3, i + 3) = rs.Fields(i).Name '取字段名字头放置在cell(3,3) Next iRange("c4").CopyFromRecordset rsrs.CloseCon.CloseSet rs = NothingSet Con = NothingMsgBox "提取完毕" & "耗时" & Round(Timer - t, 4) & "秒" End SubSub sqlserver连接并查询()Dim Con As New ADODB.ConnectionDim strCon As StringDim rs As ADODB.Recordset '设置记录集Dim i, tt = Timer'连接远程数据库strCon = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _"User ID=sa;Pwd=123456;" & _"Initial Catalog= gydataH5 ;Data Source= 192.168.1.5 ;"'连接本地数据库' strCon = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _' "User ID=sa;Pwd=;" & _' "Initial Catalog= AdventureWorks2008;Integrated Security=SSPI"strSQL = "Select * from smscodelog"'strSQL = "Select * from person.person"Con.Open strConSet rs = Con.Execute(strSQL)For i = 0 To rs.Fields.Count - 1 '逐个字段Cells(3, i + 3) = rs.Fields(i).Name '取字段名字头放置在cell(3,3)Next iRange("c4").CopyFromRecordset rsrs.CloseCon.CloseSet rs = NothingSet Con = NothingMsgBox "提取完毕" & "耗时" & Round(Timer - t, 4) & "秒" End Sub。

Excel VBA常用代码及解释

Excel VBA常用代码及解释(1) Option Explicit解释：强制对模块内所有变量进行声明(2) Option Base 1解释：指定数组的第一个下标为1(3) On Error Resume Next解释：忽略错误继续执行VBA代码,避免出现错误消息(4) On Error GoTo 100解释：当错误发生时跳转到过程中的某个位置(5) On Error GoTo 0解释：恢复正常的错误提示(6) Application.DisplayAlerts=False解释：在程序执行过程中使出现的警告框不显示(7) Application.DisplayAlerts=True解释：在程序执行过程中恢复显示警告框(8) Application.ScreenUpdating=False解释：关闭屏幕刷新(9) Application.ScreenUpdating = True解释：打开屏幕刷新(10) Workbooks.Add()解释：创建一个新的工作簿(11) Workbooks(“book1.xls”).Activate解释：激活名为book1的工作簿(12) ThisWorkbook.Save解释：保存工作簿(13) ThisWorkbook.close解释：关闭当前工作簿(14) ActiveWorkbook.Sheets.Count解释：获取活动工作薄中工作表数(15) Active 解释：返回活动工作薄的名称(16) This 解释：返回当前工作簿名称(17) ThisWorkbook.FullName解释：返回当前工作簿路径和名(18) edRange.Rows.Count解释：当前工作表中已使用的行数(19) Rows.Count解释：获取工作表的行数(20) Sheets(Sheet1).Name= “Sum”解释：将Sheet1命名为Sum(21) ThisWorkbook.Sheets.Add Before:=Worksheets(1) 解释：添加一个新工作表在第一工作表前(22)ActiveSheet.MoveAfter:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count )解释：将当前工作表移至工作表的最后(23) Worksheets(Array(“sheet1”,”sheet2”)).Select解释：同时选择工作表1和工作表2(24) Sheets(“sheet1”).Delete或 Sheets(1).Delete解释：删除工作表1(25) edRange.FormatConditions.Delete解释：删除当前工作表中所有的条件格式(26) Cells.Hyperlinks.Delete解释：取消当前工作表所有超链接(27) ActiveCell.CurrentRegion.Select选择当前活动单元格所包含的范围，等同于快捷键Ctrl+A(28) Cells.Select解释：选定当前工作表的所有单元格(29) Range(“A1”).ClearContents解释：清除活动工作表上单元格A1中的内容。

100个vba例子程序

100个vba例子程序基本代码这些 VBA 代码将帮助您快速执行一些您经常在电子表格中执行的基本任务1.添加序列号此宏代码将帮助您在Excel 工作表中自动添加序列号，如果您处理大数据，这对您很有帮助。

要使用此代码，您需要选择要从其中开始序列号的单元格，当您运行此代码时，它会显示一个消息框，您需要在其中输入序列号的最高编号，然后单击确定。

一旦您单击“确定”，它就会简单地运行一个循环并将序列号列表添加到向下的单元格中。

2.插入多列此代码可帮助您单击一次输入多个列。

当您运行此代码时，它会询问您要添加的列数，当您单击确定时，它会在所选单元格之后添加输入的列数。

如果要在所选单元格之前添加列，请将代码中的xlToRight 替换为 xlToLeft。

3.插入多行使用此代码，您可以在工作表中输入多行。

运行此代码时，您可以输入要插入的行数，并确保选择要插入新行的单元格。

如果要在所选单元格之前添加行，请将代码中的 xlT oDown 替换为 xlT oUp。

4. 自动调整列此代码可快速自动适应工作表中的所有列。

因此，当您运行此代码时，它将选择工作表中的所有单元格并立即自动调整所有列。

5. 自动调整行您可以使用此代码自动调整工作表中的所有行。

当您运行此代码时，它将选择工作表中的所有单元格并立即自动适应所有行。

6.删除文本换行此代码将帮助您通过单击从整个工作表中删除文本换行。

它将首先选择所有列，然后删除文本换行并自动适应所有行和列。

您还可以使用 (Alt + H +W) 的快捷方式，但如果将此代码添加到快速访问工具栏，它比键盘快捷方式更方便。

7. 取消合并单元格此代码仅使用 HOME 选项卡上的取消合并选项。

使用此代码的好处是您可以将其添加到 QAT 并取消合并选择中的所有单元格。

如果您想取消合并特定范围，您可以通过替换单词选择在代码中定义该范围。

8. 打开计算器在Windows 中，有一个特定的计算器，通过使用此宏代码，您可以直接从 Excel 打开该计算器。

vba实现同一文件夹下的批量文件生成excel表格超级链接

竭诚为您提供优质文档/双击可除vba实现同一文件夹下的批量文件生成excel表格超级链接篇一：用Vba实现把多个excel文件合并到一个excel 文件的多个工作表(sheet)里打开一空白xls，按alt+F11进入宏编辑界面—>插入模块，在右边粘贴上如下代码，按F5即可运行。

功能：把多个工作簿的第一个工作表合并到一个工作簿的多个工作表，新工作表的名称等于原工作簿的名称subbooks2sheets()定义对话框变量dimfdasFiledialogsetfd=application.Filedialog(msoFiledialogFilepicke r)新建一个工作簿dimnewwbasworkbooksetnewwb=workbooks.addwithfdif.show=-1then定义单个文件变量dimvrtselecteditemasVariant定义循环变量dimiasintegeri=1开始文件检索Foreachvrtselecteditemin.selecteditems打开被合并工作簿dimtempwbasworkbooksettempwb=workbooks.open(vrtselecteditem)复制工作表tempwb.worksheets(1).copybefore:=newwb.worksheets(i) 把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即excel97-20xx的文件，如果是excel20xx，需要改成xlsxnewwb.worksheets(i).name=Vba.Replace(,". xls","")关闭被合并工作簿tempwb.closesavechanges:=Falsei=i+1nextvrtselecteditemendifendwithsetfd=nothingendsub篇二：Vba方法_-_将多个excel文件合并到一个excel 的多个sheet中Vba方法-将多个excel文件合并到一个excel的多个sheet中由上级的要求，同事需要将以前做的所有excel文件（手机话费清单表），都合并到一个excel中，并且每个excel 文件为一个sheet。

vba常用代码大全

前言我们平时在工作表xx的公式xx常常使用函数，Excel自带的常用的函数多达300多个，功能强大，丰富多彩，但是在VBAxx不能直接应用，必须在函数名前面加上对象，比如：Application.WorksheetFunction.Sum(arg1,arg2,arg3)。

而能在VBAxx直接应用的函数也有几十个，下面将逐一详细介绍常用的40个VBA函数，以供大家学习参考。

第1.1例ASC函数一、题目：要求编写一段代码，运行后得到字符串”Excel”的首字母和”e”的ASCII值。

二、代码：Sub示例_1_01()Dim myNum1%, myNum2%myNum1 = Asc("Excel")'返回69myNum2 = Asc("e")'返回101[a1] = "myNum1= ": [b1] = myNum1[a2] = "myNum2= ": [b2] = myNum2End Sub三、代码详解1、Sub示例_1_01()：宏程序的开始语句。

2、Dim myNum1%, myNum2%：变量myNum1和myNum2声明为整型变量。

也可以写为Dim myNum1 As Integer。

Integer变量存储为16位（2个字节）的数值形式，其范围为-32,768到32,767之间。

Integer的类型声明字符是百分比符号(%)。

3、myNum1 = Asc("Excel")：把Asc函数的值赋给变量myNum1。

Asc函数返回一个Integer，代表字符串中首字母的字符的ASCII代码。

语法Asc(string)必要的string（字符串）参数可以是任何有效的字符串表达式。

如果string中没有包含任何字符，则会产生运行时错误。

4、myNum2 = Asc("e")：把Asc函数的值赋给变量myNum2。

VBA数据库连接代码（自己编制成功）

VBA数据库连接代码（自己编制成功）Private Sub CommandButton1_Click()Dim i As Integer, j As Integer, sht As Worksheet 'i,j为整数变量；sht 为excel工作表对象变量，指向某一工作表Dim cn As Object '定义数据链接对象，保存连接数据库信息Dim rs As Object '定义记录集对象，保存数据表Set cn = CreateObject("ADODB.Connection") '创建数据链接对象Set rs = CreateObject("ADODB.RecordSet") '创建记录集对象Dim strCn As String, strSQL As String '字符串变量strCn = "Provider=sqloledb;Server=GuilinHu-PC\HuglSQLSEVER;Database=Hugl;Uid=sa;Pwd=HGL102643lch;" '定义数据库链接字符串’Sever =服务器名称；Database =数据库名称,Uid =sa ； Pwd = 以sa身份登录数据库的密码'下面的语句将读取数据表数据，并将它保存到excel工作表中：画两张表想像一下，工作表为一张两维表，记录集也是一张两维表strSQL = "select 姓名,性别,年龄 from 个人信息" '定义SQL查询命令字符串cn.Open strCn '与数据库建立连接，如果成功，返回连接对象cnrs.Open strSQL, cn '执行strSQL所含的SQL命令，结果保存在rs记录集对象中i = 1Set sht = ThisWorkbook.Worksheets("sheet1") '把sht指向当前工作簿的sheet1工作表Do While Not rs.EOF '当数据指针未移到记录集末尾时，循环下列操作sht.Cells(i, 1) = rs("姓名") '把当前记录的字段1的值保存到sheet1工作表的第i行第1列sht.Cells(i, 2) = rs("性别") '把当前字段2的值保存到sheet1工作表的第i行第2列sht.Cells(i, 3) = rs("年龄") '把当前字段2的值保存到sheet1工作表的第i行第2列rs.MoveNext '把指针移向下一条记录i = i + 1 'i加1，准备把下一记录相关字段的值保存到工作表的下一行Loop '循环rs.Close '关闭记录集，至此，程序将把某数据表的字段1和字段2保存在excel工作表sheet1的第1、2列，行数等于数据表的记录数End Sub'工具->引用->Microsoft ActiveX Date Object 2.0Public Sub SaveData()Dim Cnn As ADODB.ConnectionDim SQL As StringSet Cnn = New ADODB.Connection'建立于数据库的链接'这里根据你的实际值修改ConnectionString = "Driver=SQL Server;Server=服务器名称;Database=数据库;Uid=账号;Pwd=密码;"With Cnn.Provider = "SQLOLEDB".ConnectionString = "Driver=SQL Server;Server=mxb\sqlex press;Database=test;Uid=sa;Pwd=xiaoma;".OpenEnd With'保存数据r = Range("A65534").End(xlUp).RowFor i = 1 To r'拼sqlSQL = "insert into T values('"& Cells(i, 1) & "','"& Cells(i, 2) & "',"& Cells(i, 3) & ")"Cnn.Execute SQLNextCnn.CloseSet Cnn = NothingMsgBox "保存成功"End Sub上面是通过VBA,插入数据到数据库,下面是从SQL查询Excel,然后直接insert into到数据库,也可以用数据库导入向导--查询excel2007select * from OpenDataSource('Microsoft.ACE.OLEDB.12.0', 'Data Source=D:\2007.xlsx;Extended Properties="Excel 12.0;HDR=Yes;IME X=1"')...[Sheet1$]--查询excel2003select * from OpenDataSource( 'Microsoft.Jet.OLEDB.4.0','Data S ource="D:\2003.xls";Extended properties=Excel 5.0')...[Sheet1$] ;向数据库中写入Sub ReturnSQLrecord()Dim i As Integer, sht As Worksheet'定义数据链接对象，保存连接数据库信息'使用ADODB，须在菜单的Tools->References中添加引用“Microsoft ActiveX Data Objects library 2.x”Dim cn As New ADODB.ConnectionDim strCn As String, strSQL As String'定义数据库链接字符串,Server=服务器名称或IP地址(本地可填写“.”);Database=数据库名称;Uid=用户登录名;Pwd=密码strCn = "Provider=sqloledb;Server=.;Database=pubs;Uid=sa;Pwd=sa;"'清空定义的变量strSQL = ""'与数据库建立连接，如果成功，返回连接对象cncn.Open strCnSet sht = ThisWorkbook.Worksheets("sheet1")For i = 2 To 6'构造SQL命令串,对标识列job_id执行插入操作时，要设置表的IDENTITY_INSERT为打开，否则会插入失败strSQL = strSQL & "SET IDENTITY_INSERT dbo.jobs ON;insert into dbo.jobs(job_id,job_desc,min_lvl,max_lvl) values(" _ & sht.Cells(i, 1) & "," & CStr(sht.Cells(i, 2)) & "," & sht.Cells(i, 3) & "," & sht.Cells(i, 4) & ") ;"Next'执行该SQL命令串，如果SQL命令没有错误，将在数据库中添加5个记录;也可以用rs.open strSQL,cn 执行cn.Execute strSQL'关闭数据库链接,释放资源cn.CloseEnd Sub;从数据库读取Sub ReturnSQLrecord()'sht 为excel工作表对象变量,指向某一工作表Dim i As Integer, sht As Worksheet'定义数据链接对象，保存连接数据库信息'使用ADODB，须在菜单的Tools->References中添加引用“Microsoft ActiveX Data Objects library 2.x”Dim cn As New ADODB.Connection'定义记录集对象，保存数据表Dim rs As New ADODB.RecordsetDim strCn As String, strSQL As String'定义数据库链接字符串,Server=服务器名称或IP地址(本地可填写“.”);Database=数据库名称;Uid=用户登录名;Pwd=密码strCn = "Provider=sqloledb;Server=NIKEY-980114BB0;Database=pubs;Uid=sa;Pwd =sa;"'定义SQL查询命令字符串strSQL = "select job_id, job_desc from dbo.jobs"'与数据库建立连接，如果成功，返回连接对象cncn.Open strCn'执行strSQL所含的SQL命令，结果保存在rs记录集对象中rs.Open strSQL, cni = 1'把sht指向当前工作簿的sheet1工作表Set sht = ThisWorkbook.Worksheets("sheet1")'当数据指针未移到记录集末尾时，循环下列操作Do While Not rs.EOF'把当前记录的job_id字段的值保存到sheet1工作表的第i行第1列sht.Cells(i, 1) = rs("job_id")sht.Cells(i, 2) = rs("job_desc")'把指针移向下一条记录rs.MoveNexti = i + 1Loop'关闭记录集rs.Close'关闭数据库链接,释放资源 cn.CloseEnd Sub。

一簿打尽常用对象属性、vba函数(大全)超链接版

一、Application全部属性Application.ActivateMicrosoftAppApplication.ActiveCellApplication.ActiveChartApplication.ActivePrinterApplication.ActiveSheetApplication.ActiveWindowApplication.ActiveWorkbookApplication.AddChartAutoFormatApplication.AddCustomListApplication.AddInsApplication.AlertBeforeOverwritingApplication.AltStartupPathApplication.AnswerWizardApplication.ApplicationApplication.AskToUpdateLinksApplication.AssistantApplication.AutoCorrectApplication.AutoFormatAsYouTypeReplaceHyperlinks Application.AutomationSecurityApplication.AutoPercentEntryApplication.AutoRecoverApplication.BuildApplication.CalculateApplication.CalculateBeforeSaveApplication.CalculateFullApplication.CalculateFullRebuildApplication.CalculationApplication.CalculationInterruptKey Application.CalculationStateApplication.CalculationVersionApplication.CallerApplication.CanPlaySoundsApplication.CanRecordSoundsApplication.CaptionApplication.CellDragAndDropApplication.CellsApplication.CentimetersToPointsApplication.ChartsApplication.CheckAbortApplication.CheckSpellingApplication.ClipboardFormatsApplication.ColumnsAddInsmandBarsmandUnderlinesApplication.ConstrainNumericApplication.ControlCharacters Application.ConvertFormula Application.CopyObjectsWithCells Application.CreatorApplication.CursorApplication.CursorMovement Application.CustomListCount Application.DataEntryMode Application.DDEAppReturnCode Application.DDEExecute Application.DDEInitiate Application.DDEAppReturnCode Application.DDEPokeApplication.DDERequest Application.DDETerminate Application.DecimalSeparator Application.DefaultFilePath Application.DefaultSheetDirection Application.DefaultSaveFormat Application.DefaultWebOptions Application.DeleteChartAutoFormat Application.DeleteCustomList Application.DialogsApplication.DisplayAlerts Application.DisplayClipboardWindow Application.DisplayCommentIndicator Application.DisplayExcel4Menus Application.DisplayFormulaBar Application.DisplayFullScreen Application.DisplayFunctionToolTips Application.DisplayInsertOptions Application.DisplayNoteIndicator Application.DisplayPasteOptions Application.DisplayRecentFiles Application.DisplayScrollBars Application.DisplayStatusBar Application.DoubleClick Application.EditDirectlyInCell Application.EnableAnimations Application.EnableAutoComplete Application.EnableCancelKey Application.EnableEvents Application.EnableSound Application.ErrorCheckingOptions Application.EvaluateApplication.Excel4IntlMacroSheets Application.Excel4MacroSheetsApplication.ExecuteExcel4Macro Application.ExtendListApplication.FeatureInstall Application.FileConverters Application.FileDialogApplication.FileFindApplication.FileSearchApplication.FindFileApplication.FindFormatApplication.FixedDecimal Application.FixedDecimalPlaces Application.GenerateGetPivotData Application.GetCustomListContents Application.GetCustomListNum Application.GetOpenFilename Application.GetPhonetic Application.GetSaveAsFilename Application.GotoApplication.HeightApplication.HelpApplication.HinstanceApplication.HwndApplication.IgnoreRemoteRequests Application.InchesToPoints Application.InputBoxApplication.Interactive Application.International Application.IntersectApplication.IterationnguageSettings Application.LeftApplication.LibraryPath Application.MacroOptions Application.MailLogoffApplication.MailLogonApplication.MailSession Application.MailSystemApplication.MapPaperSize Application.MathCoprocessorAvailable Application.MaxChangeApplication.MaxIterations Application.MemoryFreeApplication.MemoryTotal Application.MemoryUsedApplication.MouseAvailable Application.MoveAfterReturn Application.MoveAfterReturnDirectionsworkTemplatesPath Application.NewWorkbook Application.NextLetter Application.ODBCErrors Application.ODBCTimeout Application.OLEDBErrors Application.OnKeyApplication.OnRepeat Application.OnTimeApplication.OnUndoApplication.OnWindow Application.OperatingSystem anizationName Application.ParentApplication.PathApplication.PathSeparator Application.PivotTableSelection Application.PreviousSelections Application.ProductCode Application.PromptForSummaryInfo Application.QuitApplication.RangeApplication.ReadyApplication.RecentFiles Application.RecordMacro Application.RecordRelative Application.ReferenceStyle Application.RegisteredFunctions Application.RegisterXLL Application.RepeatApplication.ReplaceFormat Application.RollZoom Application.RowsApplication.RTDApplication.RunApplication.SaveWorkspace Application.ScreenUpdating Application.Selection Application.SendKeys Application.SetDefaultChart Application.SheetsApplication.SheetsInNewWorkbook Application.ShowChartTipNames Application.ShowChartTipValues Application.ShowStartupDialogApplication.ShowToolTipsApplication.ShowWindowsInTaskbar Application.SmartTagRecognizers Application.SpeechApplication.SpellingOptionsApplication.StandardFontApplication.StandardFontSizeApplication.StartupPathApplication.StatusBarApplication.TemplatesPathApplication.ThisCellApplication.ThisWorkbookApplication.ThousandsSeparatorApplication.TopApplication.TransitionMenuKeyApplication.TransitionMenuKeyAction Application.TransitionNavigKeys Application.UndoApplication.UnionableHeightableWidthedObjectserControlerLibraryPatherNameeSystemSeparators Application.ValueApplication.VBEApplication.VersionApplication.VisibleApplication.VolatileApplication.WaitApplication.WatchesApplication.WidthApplication.WindowsApplication.Windows.Count '举例Application.WindowsForPensApplication.WindowStateApplication.WorkbooksApplication.WorksheetFunctionApplication.WorksheetFunction.IsText '举例Application.WorksheetsApplication.Worksheets.Add '举例二、thisworkbook全部属性四、range全部属性With ThisWorkbook With Range("a1").AcceptAllChanges.Activate.AcceptLabelsInFormulas.AddComment.Activate.AddIndent.ActiveChart.Address.ActiveSheet.AddressLocal.AddToFavorites.AdvancedFilter.Application.AllowEdit.AutoUpdateFrequency.Application.AutoUpdateSaveChanges.ApplyNames.BreakLink.ApplyOutlineStyles .BuiltinDocumentProperties.Areas.CalculationVersion.AutoComplete.CanCheckIn.AutoFill.ChangeFileAccess.AutoFilter.ChangeHistoryDuration.AutoFit.ChangeLink.AutoFormat.Charts.AutoOutline.CheckIn.BorderAround.Close.Borders.CodeName.Calculate.Colors.Cells.CommandBars.Characters.ConflictResolution.CheckSpelling.Container.Clear.CreateBackup.ClearComments.Creator.ClearContents.CustomDocumentProperties.ClearFormats.CustomViews.ClearNotes.Date1904.ClearOutline.DeleteNumberFormat.Column.DisplayDrawingObjects.ColumnDifferences .EnableAutoRecover.Columns.EndReview.ColumnWidthment.Excel4IntlMacroSheets.ColumnWidthment.ExclusiveAccess.Consolidate.FileFormat.Copy.FollowHyperlink.CopyFromRecordset .ForwardMailer.CopyPicture.FullName.Count.FullNameURLEncoded.CreateNames.HasPassword.CreatePublisher.HasRoutingSlip.Creator.HighlightChangesOnScreen.CurrentArray.HighlightChangesOptions.CurrentRegion.HTMLProject.Cut.IsAddin.DataSeries.IsInplace.Delete.KeepChangeHistory.Dependents.LinkInfo.DialogBox.LinkSources.DirectDependents.ListChangesOnNewSheet.DirectPrecedents.Mailer.Dirty.MergeWorkbook.EditionOptions.MultiUserEditing.End.Name.EntireColumn.Names.EntireRow.NewWindow.Errors.OpenLinks.FillDown.Parent.FillLeft.Password.FillRight.PasswordEncryptionAlgorithm.FillUp.PasswordEncryptionFileProperties.Find.PasswordEncryptionKeyLength.FindNext.PasswordEncryptionProvider.FindPrevious.Path.Font.PersonalViewListSettings.FormatConditions.PersonalViewPrintSettings.Formula.PivotCaches.FormulaArray.Post.FormulaHidden.PrecisionAsDisplayed.FormulaLabel.PrintOut.FormulaLocal.PrintPreview.FormulaR1C1.Protect.FormulaR1C1Local.ProtectSharing.FunctionWizard.ProtectStructure.GoalSeek.ProtectWindows.Group.PublishObjects.HasArray.PurgeChangeHistoryNow.HasFormula.ReadOnly.Height.ReadOnlyRecommended.Hidden.RecheckSmartTags.HorizontalAlignment .RefreshAll.Hyperlinks.RejectAllChanges.ID.ReloadAs.IndentLevel.RemovePersonalInformation.Insert.RemoveUser.InsertIndent.Reply.Interior.ReplyAll.Item.ReplyWithChanges.Justify.ResetColors.Left.RevisionNumber.ListHeaderRows.Route.ListNames.Routed.LocationInTable .RoutingSlip.Locked.RunAutoMacros.Merge.Save.MergeArea.SaveAs.MergeCells.Saved.NavigateArrow.SaveLinkValues.Next.SendForReview.NoteText.SendMail.NumberFormat.SendMailer.NumberFormatLocal .SetLinkOnData.Offset.SetPasswordEncryptionOptions.Orientation.Sheets.OutlineLevel.ShowConflictHistory.PageBreak.ShowPivotTableFieldList.Parent.SmartTagOptions.Parse.Styles.PasteSpecial.TemplateRemoveExtData.Phonetic.Unprotect.Phonetics.UnprotectSharing.PivotCell.UpdateFromFile.PivotField.UpdateLink.PivotItem.UpdateLinks.PivotTable.UpdateRemoteReferences.Precedents.UserStatus.PrefixCharacter .VBASigned.Previous.VBProject.PrintOut.WebOptions.PrintPreview.WebPagePreview.QueryTable.Windows.Range.Worksheets.ReadingOrder.WritePassword.RemoveSubtotal.WriteReserved.Replace.WriteReservedBy.Resizeend with.Row.RowDifferences.RowHeight***************************.Rows三、With Sheets 'sheets属性.Run.Add.Select.Application.SetPhonetic.Copy.Show.Count.ShowDependents.Creator.ShowDetail.Delete.ShowErrors.FillAcrossSheets.ShowPrecedents.HPageBreaks.ShrinkToFit.Item.SmartTags.Move.Sort.Parent.SortSpecial.PrintOut.SoundNote.PrintPreview.Speak.Select.SpecialCells.Visible.Style.VPageBreaks.SubscribeToEnd With.Subtotal.Summary.Table.Text.TextToColumns.Top.Ungroup.UnMerge.UseStandardHeight.UseStandardWidth.Validation.Value.Value2.VerticalAlignment.Width.Worksheet.WrapTextend with。

VBA中数据库连接的技巧与方法

VBA中数据库连接的技巧与方法VBA（Visual Basic for Applications）是一种广泛应用于Microsoft Office软件中的编程语言，通过VBA，用户可以自动化执行各种操作，包括与数据库的连接与数据操作。

在本文中，我们将探讨VBA中数据库连接的技巧与方法，帮助读者更好地利用VBA进行数据库操作。

1. VBA中的数据库连接对象在VBA中，我们可以使用ADODB（ActiveX Data Objects Database）库来创建数据库连接对象。

ADODB库提供了多种数据库连接方式，包括ODBC（Open Database Connectivity）、ODBC数据源名称（DSN）和本地数据源，以便于连接各种类型的数据库，比如Access、SQL Server、Oracle等。

使用ADODB的示例代码如下：```vbaDim conn As ObjectSet conn = CreateObject("ADODB.Connection")conn.ConnectionString ="Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\YourDatabase.mdb;"conn.Open```上述代码创建了一个conn对象，并指定了连接字符串，连接字符串中包含了数据库的驱动程序（Provider）和数据源（Data Source）信息。

这里假设我们连接的是Access数据库。

2. 连接到不同类型的数据库可以根据不同类型的数据库调整连接字符串。

下面是一些常见数据库的连接字符串示例：- Access数据库：```vbaconn.ConnectionString ="Provider=Microsoft.Jet.OLEDB.4.0;DataSource=C:\YourDatabase.mdb;"```- SQL Server数据库：```vbaconn.ConnectionString = "Provider=SQLOLEDB;Data Source=YourServer;Initial Catalog=YourDatabase;UserID=YourUsername;Password=YourPassword;"```- Oracle数据库：```vbaconn.ConnectionString ="Provider=OraOLEDB.Oracle;Data Source=YourServer;User ID=YourUsername;Password=YourPassword;"```通过修改连接字符串，可以连接到不同类型的数据库。

vba hyperlinks的用法

vba hyperlinks的用法VBA (Visual Basic for Applications) 是一种用于在Microsoft Office产品中编写宏的编程语言。

在VBA中，我们可以使用超链接（hyperlinks）来连接不同的文档、网页或者执行VBA代码中的其他程序。

本文将详细介绍VBA超链接的用法，包括如何添加、修改和删除超链接，以及如何在VBA代码中使用超链接。

一、添加超链接在VBA中，可以使用Hyperlinks对象来添加超链接。

Hyperlinks对象是指向单元格上的超链接的集合，该集合位于Worksheet对象上。

下面是一个简单的示例代码，演示了如何在VBA中添加超链接到单元格：Sub AddHyperlink()Dim ws As WorksheetSet ws = ThisWorkbook.Worksheets("Sheet1") '替换为你的工作表的名称Dim rng As RangeSet rng = ws.Range("A1") '替换为你要添加超链接的单元格Dim hyperlink As HyperlinkSet hyperlink = rng.Hyperlinks.Add(rng, " '替换为你的目标网址MsgBox "超链接已添加到单元格" & rng.AddressEnd Sub在上面的示例代码中，首先声明了一个Worksheet对象ws，它被设置为该示例工作簿（ThisWorkbook）中名为"Sheet1"的工作表。

然后，声明了一个Range对象rng，它被设置为需要添加超链接的单元格。

接下来，声明了一个Hyperlink对象hyperlink，并通过调用Add方法向rng单元格添加了一个超链接。

可以通过更改Add方法的第二个参数来指定超链接的目标地址。

WORDVBA清除word中所有超链接

WORDVBA清除word中所有超链接WORD VBA清除word超链接，提供三种方法，代码如下：Sub SFHyperlinks2() '取消文字图片形状(含文字)超链接On Error Resume NextDim oshape As ShapeFor Each oshape In ActiveDocument.Shapes '任何形状、图片oshape.Hyperlink.Deleteoshape.TextFrame.TextRange.Fields.Unlink '图形文本框中的文字 NextFor Each oField In ActiveDocument.Fields '任何文字If oField.Type = wdFieldHyperlink Then oField.Unlink Next End SubSub 清空超链接()On Error Resume NextDim oField As Field, oInlineshape As InlineShape, oShape As ShapeFor Each oField In ActiveDocument.FieldsIf oField.Type = wdFieldHyperlink ThenoField.UnlinkEnd IfNextFor Each oInlineshape In ActiveDocument.InlineShapesoInlineshape.Hyperlink.DeleteNextFor Each oShape In ActiveDocument.ShapesoShape.Hyperlink.DeleteFor Each oField In oShape.TextFrame.TextRange.FieldsIf oField.Type = wdFieldHyperlink ThenoField.UnlinkEnd IfNextFor Each oInlineshape In oShape.TextFrame.TextRange.InlineShapesoInlineshape.Hyperlink.DeleteNextNextEnd SubSub SFHyperlinks2() '取消文字图片形状(含文字)超链接On Error Resume NextDim oshape As Shape, oinlineshape As InlineShape, olink As HyperlinkFor Each oshape In ActiveDocument.Shapes '任何形状oshape.Hyperlink.Deleteoshape.TextFrame.TextRange.Fields.Unlink '图形文本框中的文字For Each olink In oshape.TextFrame.T extRange.Hyperlinksolink.DeleteNextIf Val(Application.Version) > 12 ThenFor Each oinlineshape Inoshape.TextFrame.TextRange.InlineShapes '此3句仅适用word2010,在word2003中会卡死oinlineshape.Hyperlink.Delete '浮动或嵌入式图形中的嵌入式图片NextEnd IfNextFor Each oinlineshape In ActiveDocument.InlineShapes '此3句在word2003中可不用oinlineshape.Hyperlink.Delete '嵌入式图片 NextFor Each oField In ActiveDocument.Fields '任何文字If oField.Type = wdFieldHyperlink Then oField.Unlink Next End Sub。

VBA各种超链接代码

VBA各种超链接代码功能：遍历指定路径中的文件夹，并在当前工作表中添加超链接Sub chiefzjh1()Dim i%, r%, mFdr$, mPth$, aDrs()r = 1mpath = "h:\"mFdr = Dir(mpath, vbDirectory)Do While mFdr <> ""If mFdr <> "." And mFdr <> ".." ThenIf GetAttr(mpath & mFdr) = 16 Then 'folder=16,file=32 ReDim Preserve aDrs(1 To r)aDrs(r) = mpath & mFdrr = r + 1End IfEnd IfmFdr = DirLoopWith ActiveSheetFor i = 1 To r - 1.Hyperlinks.Add anchor:=.Cells(i, 1), Address:=aDrs(i) Next iEnd WithErase aDrsEnd Sub**********Remark***************常数值描述vbNormal 0 常规vbReadOnly 1 只读vbHidden 2 隐藏vbSystem 4 系统文件vbDirectory 16 目录或文件夹vbArchive 32 上次备份以后，文件已经改变vbalias 64 指定的文件名是别名。

====================================== ====================================== 功能：遍历本路径中的文件，并在当前工作表1A列中添加超链接Sub chiefzjh2()Dim mNm$, mPth$, dic, r%Set dic = CreateObject("scripting.dictionary")mPth = "c:\"mNm = Dir(mPth & "*.*")Do While mNm <> ""If GetAttr(mPth & mNm) = 32 Then dic.Add mNm, ""mNm = DirLoop[a1].Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)With Sheet1For r = 1 To dic.Count.Hyperlinks.Add anchor:=Cells(r, 1), Address:=mPth & .Cells(r, 1).TextNextEnd WithEnd Sub====================================== ======================================功能：遍历本工作簿中所有工作表，并在当前工作表1A列中添加超链接Sub chiefzjh3()With Sheet1[a1] = "Sheets Link:"For i% = 2 To Worksheets.Count.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _SubAddress:=Sheets(i).Name & "!a1", TextToDisplay:=Sheets(i).NameNext iEnd WithEnd Sub====================================== ====================================== 功能：更改数据有效性设置后，把有效性不规范的单元格地址在表2中写出来，并超链接'活动单元格先定位于含有有效性的单元格，再运行这段宏，以取得有效性内容Sub chiefzjh4()Application.ScreenUpdating = FalseDim tSt$, i%, mC%, r%, Sht$, mAdd(), mFml$mC = ActiveCell.ColumnSht = /doc/173303126.html,tSt = ActiveCell.Validation.Formula1For i = 1 To ActiveCell.End(xlDown).RowIf InStr(tSt, Cells(i, mC).Text) = 0 Thenr = r + 1ReDim Preserve mAdd(1 T o r)mAdd(r) = Cells(i, mC).Address(0, 0)End IfNext i'结果输出到sheet2 A列，从第一行开始，自行修改Sheet2.ActivateColumns(1).ClearContentsWith ActiveSheetFor i = 1 To r.Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", _ SubAddress:=Sht & "!" & mAdd(i), TextToDisplay:=mAdd(i) Next iEnd WithApplication.ScreenUpdating = TrueEnd Sub。