九色国产,午夜在线视频,新黄色网址,九九色综合,天天做夜夜做久久做狠狠,天天躁夜夜躁狠狠躁2021a,久久不卡一区二区三区

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代碼

假設(shè)要插入的列為B列，A列是對(duì)應(yīng)的圖片名稱，圖片路徑和工作表路徑需要一致，插入的圖片從B2開始

無邊距：

'無邊距
Sub aaimg()
  Dim a As Shape
  Dim rg As Range
  r_num = [a65536].End(xlUp).Row
  '先刪除已經(jīng)存在的
  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
   '設(shè)置范圍
   For Each rg In Range('b2:b' & r_num)
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
   '報(bào)錯(cuò)就繼續(xù)
    On Error Resume Next
   '無邊框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 設(shè)置偏移
   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
  '先刪除已經(jīng)存在的
  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
   '設(shè)置范圍
   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
   '報(bào)錯(cuò)就繼續(xù)
    On Error Resume Next
   '無邊框
   Selection.ShapeRange.Line.Visible = msoFalse
   Rem 設(shè)置偏移
   Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & '\' & rg.Offset(0, -1) & '.png'
   Next rg
End Sub

3.批量下載文件或圖片的VBA代碼

假設(shè)下載文件的url在A列，文件名稱在B列，要保存的文件類型在C列

Sub downloadimg()
'給定網(wǎng)址下載圖片或視頻
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      '為空則默認(rèn)為數(shù)字
        f_type = Range('c' & i).Value
        On Error Resume Next
        H.Open 'GET', Range('A' & i), False  '網(wǎng)絡(luò)中的文件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.獲取最后一列的行號(hào)的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.二維數(shù)組與一維數(shù)組，獲取某行與某列，并轉(zhuǎn)為一維數(shù)組

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.打開工作簿，并將該工作表的某個(gè)工作表放入數(shù)組的VBA代碼

Function get_arr(file, sh_name)
    '打開一個(gè)工作簿，并返回一個(gè)數(shù)組，第一個(gè)為路徑，第二個(gè)參數(shù)為工作表的序號(hào)（工作表名稱）
    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.循環(huán)當(dāng)前工作簿，對(duì)每個(gè)工作表進(jìn)行操作的VBA代碼

Sub type_sum()
    For Each sht In Sheets
    sh_name = sht.Name
        Sheets(sh_name).Select
        'Call tianchong     '執(zhí)行某個(gè)操作
    Next sht
End Sub

9.在當(dāng)前工作簿增加工作表，如果名字相同會(huì)刪除

Function add_sheet(sh_name)
'添加工作表
'刪除舊數(shù)據(jù)
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并對(duì)其中內(nèi)容進(jìn)行替換

Sub open_wd2(arr)
'循環(huán)體
Application.EnableCancelKey = xlDisabled
Dim wd, w_doc As Object
Dim common_path
common_path = 'D:\new\'   '輸出的文檔位置
doc_path='D:\analyse\20191118\計(jì)算\模板.docx'  'word模板路徑
Set wd = CreateObject('Word.application')
'wd.Visible = True   '設(shè)置窗體可見
Set w_doc = wd.Documents.Open(doc_path)
Set myRange = w_doc.Content
'替換內(nèi)容
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) & '結(jié)果.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')
         '設(shè)置小數(shù)點(diǎn)前導(dǎo)0顯示即 [0.7]格式
End With
ex_path='D:\analyse\模板.xlsx'    'excel模板位置
arr1 = get_arr(ex_path, 1)  '替換的格式，get_arr為上方的函數(shù)
arr2 = get_arr(ex_path, 2)  '替換的數(shù)據(jù)
    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')
        '恢復(fù)到默認(rèn) 小數(shù)點(diǎn)前導(dǎo)0不顯示 [.7]狀態(tài)
'End With
End Sub

運(yùn)行時(shí)，需要復(fù)制本文中的5、7函數(shù)，同時(shí)設(shè)置好word模板路徑、excel模板路徑和輸出位置。

11.將當(dāng)前工作表中的公式轉(zhuǎn)換成數(shù)值

Sub shuzhi()
'公式轉(zhuǎn)為數(shù)值
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.刪除特定行

在原有數(shù)據(jù)上直接修改

Sub ffa()
'刪除對(duì)應(yīng)行
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

先備份再進(jìn)行刪除

Function add_sheet(sh_name)
'添加工作表
'刪除舊數(shù)據(jù)
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()
'刪除對(duì)應(yīng)行
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\計(jì)算\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