VBA｜幾段實(shí)用代碼

leafcho 2022-08-25 發(fā)布于浙江

展開全文

1 有內(nèi)容的最行一行,、列

lr = Range('A' & Cells.Rows.Count).End(xlUp).Row + 1lc = Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column + 1

2 數(shù)組填充

[E1:F1] = Array('產(chǎn)品名稱', '數(shù)量') '填充表頭ActiveSheet.Range('A3:B3') = Array('外部庫(kù)名稱', '描述', '文件位置') '填充表頭

3 字符串處理函數(shù)

s1 = Len(s) 求長(zhǎng)度s1 = Trim(s) 去兩邊空格s1 = Replace(s,a,b) 替換字符串s1 = LCase(s) 小寫字符串s1 = UCase(s) 大寫字符串s1 = Left(s,n) 從左邊取出n個(gè)字符s1 = Right(s,n) 從右邊取出n個(gè)字符s1 = Mid(s,i,n) 從s的第i個(gè)字符開始取出n個(gè)字符s1 = Instr(s,a) 查找字符串a(chǎn)的位置s1 = Instr(i,s,a) 從第i個(gè)字符開始尋找a,，返回a首字母的位置

4 單元格操作

合并單元格 Range.Merge拆分單元格 Range.UnMerge清除內(nèi)容 Range.ClearContents清除格式 Range.ClearFormats內(nèi)容格式全部清除 Range.Clear修改字號(hào) Range.Font.Size修改顏色Range.Font.Color = RGB(255,0,0)修改字顏色Range.Interior.Color = RGB（255,，255,，0）

5 引用方式A1和R1C1轉(zhuǎn)換

'A1轉(zhuǎn)R1C1：function TransferFromat(byval rangeAdd as string) as string     dim str as string     str =Application.ConvertFormula(rangeAdd , xlA1, xlR1C1)    TransferFromat=str end function'R1C1轉(zhuǎn)A1：function TransferFromat(byval rangeAdd as string) as string     dim str as string     str =Application.ConvertFormula(rangeAdd ,xlR1C1, xlA1 )    TransferFromat=str end functionApplication.ReferenceStyle = xlA1Application.ReferenceStyle = xlR1C1

6 清除密碼保護(hù)

Sub clearPassWord()    Dim wkb As Workbook    For Each wkb In Workbooks        If wkb.HasPassword Then            wkb.Password = ''        End If    Next wkbEnd Sub

7 空表判斷

    If Application.WorksheetFunction.CountA(Cells) <> 0 Then        MsgBox '活動(dòng)工作表中包含數(shù)據(jù),，請(qǐng)選擇一個(gè)空工作表,！'        Exit Sub    End If

8 定時(shí)運(yùn)行程序

Sub ontime()    dNextTime = DateAdd('s', 5, Now)  '5 second    Application.ontime dNextTime, 'proc'End SubSub proc()    Debug.Print 1314End Sub

9 Read a file

Const ForReading = 1Const ForWriting = 2Const ForAppending = 8Sub ReadTextFileExample()    Dim fso As Object    Set fso = CreateObject('Scripting.FileSystemObject')    Dim sourceFile As Object    Dim myFilePath As String    Dim myFileText As String    myFilePath = 'C:\mypath\to\myfile.txt'    GoalKicker.com – VBA Notes for Professionals 96    Set sourceFile = fso.OpenTextFile(myFilePath, ForReading)    myFileText = sourceFile.ReadAll ' myFileText now contains the content of the text file    sourceFile.Close ' close the file    ' do whatever you might need to do with the text    ' You can also read it line by line    Dim line As String    Set sourceFile = fso.OpenTextFile(myFilePath, ForReading)    While Not sourceFile.AtEndOfStream ' while we are not finished reading through the file        line = sourceFile.ReadLine        ' do something with the line...    Wend    sourceFile.CloseEnd Sub

10 Creating and write a text file

Sub CreateTextFileExample()    Dim fso As Object    Set fso = CreateObject('Scripting.FileSystemObject')    Dim targetFile As Object    Dim myFilePath As String    Dim myFileText As String    myFilePath = 'C:\mypath\to\myfile.txt'    Set targetFile = fso.CreateTextFile(myFilePath, True) ' this will overwrite any existing file    targetFile.Write 'This is some new text'    targetFile.Write ' And this text will appear right after the first bit of text.'    targetFile.WriteLine 'This bit of text includes a newline character to ensure each write takes its own line.'    targetFile.Close ' close the fileEnd Sub

11 設(shè)置條件格式

Sub 設(shè)置條件格式()    Dim rng1 As Range    Set rng1 = Sheet1.Range('C2:E6')    '添加條件格式,，成績(jī)大于或等于90 的格式    With rng1.FormatConditions.Add(Type:=xlCellValue, _        Operator:=xlGreaterEqual, Formula1:=90)        With .Borders            .LineStyle = xlContinuous            .Weight = xlThin            .ColorIndex = 6        End With        With .Font            .Bold = True            第4 章 Range 對(duì)象操作技巧 105            .ColorIndex = 3        End With    End With    '添加條件格式,，成績(jī)小于60 的格式    With rng1.FormatConditions.Add(Type:=xlCellValue, _        Operator:=xlLess, Formula1:=60)        With .Font            .Bold = True            .ColorIndex = 10        End With    End WithEnd Sub

12 清除條件格式

Sub 清除條件格式()    Cells.FormatConditions.DeleteEnd Sub

13 排序工作表

Sub 排序工作表()    Dim i As Long, j As Long    For i = 1 To Worksheets.Count        For j = 1 To Worksheets.Count - 1            If UCase$(Worksheets(j).Name) > UCase$(Worksheets(j + 1).Name) Then                Worksheets(j).Move After:=Worksheets(j + 1)            End If        Next j    Next iEnd Sub

14 重命名工作表

Sub 重命名工作表()    Dim str1 As String    Do    Err.Clear    str1 = Application.InputBox( _    prompt:='請(qǐng)輸入工作表的新名稱（輸入空白，則退出程序）：', _    Title:='重命名工作表', Type:=2)    If str1 = '' Or str1 = 'False' Then Exit Do        On Error Resume Next        ActiveSheet.Name = str1        If Err.Number <> 0 Then            MsgBox Err.Number & ' ' & Err.Description            Err.Clear        End If    Loop While 1 = 1End Sub

15 工作表標(biāo)簽顏色設(shè)置與恢復(fù)

Sub 設(shè)置工作表標(biāo)簽顏色()    For Each sh In Worksheets        r = Rnd() * 255        g = Rnd() * 255        b = Rnd() * 255        sh.Tab.Color = RGB(r, g, b)    NextEnd SubSub 恢復(fù)工作表標(biāo)簽顏色()    For Each sht In Worksheets        sht.Tab.ColorIndex = xlColorIndexNone    NextEnd Sub

16 判斷工作簿是否打開

Private Function WorkbookIsOpen(WorkBookName As String) As Boolean    '如果該工作簿已打開,，則返回真    Dim wb As Workbook    On Error Resume Next    Set wb = Workbooks(WorkBookName)    If Err = 0 Then        WorkbookIsOpen = True    Else        WorkbookIsOpen = False    End IfEnd Function

17 工作簿備份：

Sub 備份工作簿()    Dim wb As Workbook, FileName As String, i As Integer, OK As Boolean    Set wb = ActiveWorkbook '獲取對(duì)當(dāng)前工作簿的引用    If wb.Path = '' Then '如果還未保存        Application.Dialogs(xlDialogSaveAs).Show '顯示另存為對(duì)話框    End If    FileName = wb.FullName '獲取工作簿的全路徑名稱    i = InStrRev(FileName, '.')    If i > 0 Then FileName = Left(FileName, i - 1) '生成擴(kuò)展名'.bak'        FileName = FileName & '.bak'        OK = False        On Error GoTo err1        With wb            Application.StatusBar = '正在保存工作簿...'            .Save '保存工作簿            Application.StatusBar = '正在備份工作簿...'            .SaveCopyAs FileName '備份工作簿            OK = True        End Witherr1:        Set wb = Nothing        Application.StatusBar = False '恢復(fù)狀態(tài)欄        If Not OK Then '如果未備份成功            MsgBox '備份工作簿操作失敗!', vbExclamation, ThisWorkbook.Name        End If    End Sub

18 工作簿之間數(shù)據(jù)引用：

Sub 獲取其他工作簿數(shù)據(jù)()    Dim wb As Workbook    '以只讀方式打開工作簿    Set wb = Workbooks.Open('F:\工作簿間數(shù)據(jù)引用\a\a.xlsx', True, True)    With ThisWorkbook.Worksheets('Sheet1') '從工作簿中讀取數(shù)據(jù)        ' 方式1,，從打開的工作簿引用        .Range('B2') = wb.Worksheets('Sheet1').Range('B2') + _        wb.Worksheets('Sheet1').Range('B3') + _        wb.Worksheets('Sheet1').Range('B4')        ' 方式2，使用公式和絕對(duì)路徑        .Range('B3').Formula = '=SUM('F:\工作簿間數(shù)據(jù)引用\b\[b.xlsx]Sheet1'!$C$2:$C$4)'        ' 方式3,，將方式2的使用定義為一個(gè)函數(shù)        .Range('B4').Formula = GetClosedData('F:\工作簿間數(shù)據(jù)引用\b', 'b.xlsx', 'Sheet1', 'D2:D4')    End With    wb.Close False '關(guān)閉打開的工作簿且不保存任何變化    Set wb = Nothing '釋放內(nèi)存End SubFunction GetClosedData(ByVal path As String, ByVal WorkbookName As String, _    ByVal SheetName As String, ByVal RangeName As String)    '參數(shù)Path 為工作簿路徑    '參數(shù)WorkbookName 為工作簿名稱    '參數(shù)SheetName 為工作表名稱    '參數(shù)RangeName 為單元格區(qū)域    Dim r    r = '=sum('' & path & '\[' & WorkbookName & ']'    r = r & SheetName & ''!' & RangeName & ')'    GetClosedData = rEnd Function

19 鎖定和隱藏公式

Sub 鎖定和隱藏公式()    If ActiveSheet.ProtectContents = True Then        MsgBox '工作表已保護(hù),！'        Exit Sub    End If       Worksheets('Sheet1').Range('A1').CurrentRegion.Select    Selection.Locked = False    Selection.FormulaHidden = False       Selection.SpecialCells(xlCellTypeFormulas).Select    Selection.Locked = True    Selection.FormulaHidden = True       Worksheets('Sheet1').Protect DrawingObjects:=True, Contents:=True, Scenarios:=True    Worksheets('Sheet1').EnableSelection = xlNoRestrictionsEnd SubSub 取消保護(hù)()    ActiveSheet.Unprotect    Worksheets('Sheet1').Range('A1').CurrentRegion.Select    Selection.Locked = False    Selection.FormulaHidden = FalseEnd Sub

20 整點(diǎn)報(bào)時(shí)

'打開整點(diǎn)報(bào)時(shí)Sub starttime()    Application.OnTime EarliestTime:=TimeSerial((Hour(Now) + 1) Mod 24, 0, 0), _    Procedure:='starttime'    MsgBox '現(xiàn)在時(shí)間是：' & Hour(Now) & ' 點(diǎn)！'End Sub'結(jié)束整點(diǎn)報(bào)時(shí)Sub endtime()    On Error Resume Next    Application.OnTime EarliestTime:=TimeSerial((Hour(Now) + 1) Mod 24, 0,    0), _    Procedure:='starttime', schedule:=FalseEnd Sub

ref:

吳永佩,，成麗君《征服Excel VBA：讓你工作效率倍增的239 個(gè)實(shí)用技巧》

－End－

本站是提供個(gè)人知識(shí)管理的網(wǎng)絡(luò)存儲(chǔ)空間,，所有內(nèi)容均由用戶發(fā)布，不代表本站觀點(diǎn),。請(qǐng)注意甄別內(nèi)容中的聯(lián)系方式,、誘導(dǎo)購(gòu)買等信息，謹(jǐn)防詐騙,。如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容,，請(qǐng)點(diǎn)擊一鍵舉報(bào)。

轉(zhuǎn)藏 分享

QQ空間 QQ好友新浪微博微信

獻(xiàn)花（0） +1

來(lái)自： leafcho > 《辦公》

舉報(bào)/認(rèn)領(lǐng)