OFFICE Excel表格中常用的vba代码集锦

拾叁亿人 2023-03-29 发布于云南

展开全文

1.用于批量删除图片的VBA代码


sub del_pic()
 For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
end sub()

2.批量插入图片的VBA代码

假设要插入的列为B列，A列是对应的图片名称，图片路径和工作表路径需要一致，插入的图片从B2开始

无边距：


'无边距
Sub aaimg()
  Dim a As Shape
  Dim rg As Range
  r_num = [a65536].End(xlUp).Row
  '先删除已经存在的
  For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
   '宽度
    Columns('B:B').ColumnWidth = 11
    '高度
    Rows('2:' & r_num).RowHeight = 92
   '设置范围
   For Each rg In Range('b2:b' & r_num)
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
   '报错就继续
    On Error Resume Next
   '无边框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 设置偏移
   Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & '\' & rg.Offset(0, -1) & '.png'
   Next rg
End Sub

有边距：


'有边距
Sub aaimg()
  Dim a As Shape
  Dim rg As Range
  r_num = [a65536].End(xlUp).Row
  '先删除已经存在的
  For Each a In ActiveSheet.Shapes
    If a.Type <> 8 Then
      a.Delete
    End If
   Next a
   '宽度
    Columns('B:B').ColumnWidth = 11
    '高度
    Rows('2:' & r_num).RowHeight = 92
   '设置范围
   For Each rg In Range('b2:b' & r_num)
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left + 4, rg.Top + 4, rg.Width - 8, rg.Height - 8).Select
   '报错就继续
    On Error Resume Next
   '无边框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 设置偏移
   Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & '\' & rg.Offset(0, -1) & '.png'
   Next rg
End Sub

3.批量下载文件或图片的VBA代码

假设下载文件的url在A列，文件名称在B列，要保存的文件类型在C列


Sub downloadimg()
'给定网址下载图片或视频
Dim H, S, f_type, name, filename
'f_type 文件类型  name 文件名称  filename 路径名称
r_num = [a65536].End(xlUp).Row
filename = ThisWorkbook.Path & '\' & 'img'
If Dir(filename, vbDirectory) = '' Then  '如果文件不存在
    MkDir filename
    GoTo main
End If
main:
    Set H = CreateObject('Microsoft.XMLHTTP')
    For i = 1 To r_num
        name = Range('b' & i).Value
        If name = '' Then name = i      '为空则默认为数字
        f_type = Range('c' & i).Value
        On Error Resume Next
        H.Open 'GET', Range('A' & i), False  '网络中的文件URL
        H.send
        Set S = CreateObject('ADODB.Stream')
        S.Type = 1
        S.Open
        S.write H.Responsebody
        S.savetofile filename & '\' & name & '.' & f_type, 2 '本地保存文件名
        S.Close
    Next i
End Sub

4.查找本周的周一以及周日


Sub ff()
d = '2019/8/12'
MsgBox DateAdd('d', -(Weekday(d, 0) - 1), d)   '周一
MsgBox DateAdd('d', (7 - Weekday(d, 0)), d)    '周日
'MsgBox Weekday(d, 0)
End Sub

5.获取最后一列的行号的VBA代码


Function get_col(col_num)
 '输出字母形式的列名称
    If col_num <= 26 Then
        col_str = Chr(64 + col_num)
    Else
        b_num = col_num \ 26
        e_num = col_num Mod 26
        If e_num = 0 Then
            col_str = Chr(64 + b_num - 1) + Chr(64 + 26)
        Else
            col_str = Chr(64 + b_num) + Chr(64 + e_num)
        End If
    End If
    get_col = col_str
End Function

6.二维数组与一维数组，获取某行与某列，并转为一维数组


Sub ar()
Dim arr1(1 To 6, 1 To 3), arr2()
Dim i, j As Integer
For i = 1 To 6
    For j = 1 To 3
        arr1(i, j) = i * j
    Next j
Next i
'获取第三列
arr2 = Application.Transpose(Application.Index(arr1, 0, 3))
'获取第三行
arr2 = Application.Index(arr1, 3, 0)
For i = 1 To UBound(arr2)
    Debug.Print arr2(i)
Next i
End Sub

7.打开工作簿，并将该工作表的某个工作表放入数组的VBA代码


Function get_arr(file, sh_name)
    '打开一个工作簿，并返回一个数组，第一个为路径，第二个参数为工作表的序号（工作表名称）
    Dim wb As Workbook
    Set wb = Workbooks.Open(file)
    wb.Sheets(sh_name).Select
    row_num = [b65536].End(xlUp).Row
    col_num = ActiveSheet.UsedRange.Columns.Count
    col_str = get_col(col_num)   '获取行名称
    arr = Sheets(sh_name).Range('a1:' & col_str & row_num)
    wb.Close False
    Set wb = Nothing
    get_arr = arr
End Function

8.循环当前工作簿，对每个工作表进行操作的VBA代码


Sub type_sum()
    For Each sht In Sheets
    sh_name = sht.Name
        Sheets(sh_name).Select
        'Call tianchong     '执行某个操作
    Next sht
End Sub

9.在当前工作簿增加工作表，如果名字相同会删除


Function add_sheet(sh_name)
'添加工作表
'删除旧数据
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name = sh_name Then sht.Delete
Next sht
Application.DisplayAlerts = True
'添加新工作表
Sheets.add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sh_name
End Function

10.打开word并对其中内容进行替换


Sub open_wd2(arr)
'循环体
Application.EnableCancelKey = xlDisabled
Dim wd, w_doc As Object
Dim common_path
common_path = 'D:\new\'   '输出的文档位置
doc_path='D:\analyse\20191118\计算\模板.docx'  'word模板路径
Set wd = CreateObject('Word.application')
'wd.Visible = True   '设置窗体可见
Set w_doc = wd.Documents.Open(doc_path)
Set myRange = w_doc.Content
'替换内容
For i = UBound(arr) To 2 Step -1
    myRange.Find.Execute FindText:=arr(i, 2), _
    ReplaceWith:=arr(i, 3), Replace:=wdReplaceAll
Next i
w_doc.SaveAs2 common_path & arr(2, 3) & '结果.docx'
w_doc.Close
'退出word程序
wd.Quit
Set wd = Nothing
Set w_doc = Nothing
End Sub
Sub main_func()
Application.EnableCancelKey = xlDisabled
With CreateObject('Wscript.Shell')
    Call .RegWrite('HKEY_CURRENT_USER\Control Panel\International\iLZero', '1')
         '设置小数点前导0显示即 [0.7]格式
End With
ex_path='D:\analyse\模板.xlsx'    'excel模板位置
arr1 = get_arr(ex_path, 1)  '替换的格式，get_arr为上方的函数
arr2 = get_arr(ex_path, 2)  '替换的数据
    For j = 2 To UBound(arr2)
        For k = 2 To UBound(arr1)
            arr1(k, 3) = CStr(arr2(j, k))
        Next k
        open_wd2 (arr1)
    Next j
'With CreateObject('Wscript.Shell')
    'Call .RegWrite('HKEY_CURRENT_USER\Control Panel\International\iLZero', '0')
        '恢复到默认 小数点前导0不显示 [.7]状态
'End With
End Sub

运行时，需要复制本文中的5、7函数，同时设置好word模板路径、excel模板路径和输出位置。

11.将当前工作表中的公式转换成数值


Sub shuzhi()
'公式转为数值
row_num = [a65536].End(xlUp).Row
col_num = ActiveSheet.UsedRange.Columns.Count
col_str = get_col(col_num)
Range('A1:' & col_str & row_num).Copy
Range('A1').Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
End Sub

12.删除特定行

在原有数据上直接修改


Sub ffa()
'删除对应行
row_num = [a65536].End(xlUp).Row
 For i = row_num To 1 Step -1
    If Cells(1, i) = '同比' Or Cells(1, i) = '' Then   '此处填写条件
        Columns(i).Delete
    End If
Next i
End Sub

先备份再进行删除


Function add_sheet(sh_name)
'添加工作表
'删除旧数据
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name = sh_name Then sht.Delete
Next sht
Application.DisplayAlerts = True
'添加新工作表
Sheets.add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sh_name
End Function
Sub ffa()
'删除对应行
row_num = [a65536].End(xlUp).Row
col_num = ActiveSheet.UsedRange.Columns.Count
col_str = get_col(col_num)
arr=Range('A1:' & col_str & row_num)
add_sheet('删除后')
Sheets('删除后').Range('a1').Resize(row_num, UBound(arr, 2)) = arr
 For i = row_num To 1 Step -1
    If Cells(1, i) = '同比' Or Cells(1, i) = '' Then   '此处填写条件
        Columns(i).Delete
    End If
Next i
End Sub

13.判断文件夹和文件是否存在的VBA代码


Sub fe()
testfile = 'D:\analyse\20191118\计算\new\'
If Dir(testfile, vbDirectory) = '' Then
    MsgBox '不存在'
Else
    MsgBox '存在'
End If
End Sub

14.添加引用


'Name: Excel Major: 1 Minor: 7 GUID: {00020813-0000-0000-C000-000000000046}
'Name: DAO Major: 5 Minor: 0 GUID: {00025E01-0000-0000-C000-000000000046}
'Name: WMPLib Major: 1 Minor: 0 GUID: {6BF52A50-394A-11D3-B153-00C04F79FAA6}
'Name: VBIDE Major: 5 Minor: 3 GUID: {0002E157-0000-0000-C000-000000000046}
'Name: Office Major: 2 Minor: 5 GUID: {2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}
'Name: stdole Major: 2 Minor: 0 GUID: {00020430-0000-0000-C000-000000000046}
'Name: Word Major: 8 Minor: 5 GUID: {00020905-0000-0000-C000-000000000046}
'Name: VBA Major: 4 Minor: 1 GUID: {000204EF-0000-0000-C000-000000000046}
Sub AutoAddRef()
Dim strGUID As String
strGUID = '{00020905-0000-0000-C000-000000000046}' 'Microsoft Windows Media Player Marjor=1 Minor=0
ThisDocument.VBProject.References.AddFromGuid GUID:=strGUID, Major:=8, Minor:=5
End Sub