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

原创已于 2023-05-15 18:18:25 修改

· 1.1w 阅读

97 ·

版权

文章标签：

#vba删除图片 #VBA获取行号 #VBA爬虫 #VBA判断文件是否存在

于 2019-08-06 12:15:33 首次发布

excel 专栏收录该内容

3 篇文章

订阅专栏

本文提供了一系列实用的VBA代码，包括批量删除和插入图片、下载文件、查找日期、数组操作、工作簿管理等，覆盖了Excel自动化处理的多个方面。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

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