引用指定位置單元內(nèi)容為部分文件名另存文件Sub 引用指定位置單元內(nèi)容為部分文件名另存文件()ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls"End Sub將A列數(shù)據(jù)排序到D列Sub 將A列數(shù)據(jù)排序到D列()[d:d] = [a:a].Value[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYesEnd Sub將指定范圍的數(shù)據(jù)排列到D列Sub 將指定范圍的數(shù)據(jù)排列到D列()Dim arr1, arr2, i%, xarr1 = Range("A1:C3")ReDim arr2(1 To UBound(arr1, 1) * UBound(arr1, 2), 1 To 1)For Each x In Application.Transpose(arr1) i = i + 1 arr2(i, 1) = xNext xRange("D1").Resize(i, 1) = arr2End Sub光標(biāo)移動(dòng)Sub 光標(biāo)移動(dòng)()ActiveCell.Offset(1, 2).Select '向下移動(dòng)1行，向右移動(dòng)2列End Sub光標(biāo)所在行上移一行Sub 光標(biāo)所在行上移一行() Dim i% i = Split(ActiveCell.Address, "$")(2) If i > 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End IfEnd Sub加數(shù)據(jù)有效限制Sub 加數(shù)據(jù)有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="bigsun010@sina.com" .IgnoreBlank = False .InCellDropdown = False .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "要奮斗就會(huì)有犧牲，死人的事是經(jīng)常發(fā)生的。" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub取消數(shù)據(jù)有效限制Sub 取消數(shù)據(jù)有效限制() With Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End WithEnd Sub重排窗口Sub 重排窗口() Application.CommandBars("Web").Visible = False Application.CommandBars("我的工具").Visible = False Windows.Arrange ArrangeStyle:=xlCascadeEnd Sub按當(dāng)前單元文本選擇打開(kāi)指定文件單元Sub 選擇打開(kāi)文件單元() Dim a a = ActiveCell.Value Range(a).Worksheet.Activate Range(a).SelectEnd Sub回車光標(biāo)向右Sub 錄入光標(biāo)向右() Application.MoveAfterReturnDirection = xlToRightEnd Sub回車光標(biāo)向下Sub 錄入光標(biāo)向下() Application.MoveAfterReturnDirection = xlDownEnd Sub保護(hù)工作表時(shí)取消選定鎖定單元Sub 取消選定鎖定單元() ActiveSheet.EnableSelection = xlUnlockedCells '用于2000版End Sub保存并退出ExcelSub 保存并退出Excel()Application.SendKeys ("{ENTER}{ENTER}%fx")ActiveWorkbook.SaveEnd Sub隱藏/顯示指定列空值行Sub 隱藏/顯示E列空值行()Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not
(Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)End Sub深度隱藏指定工作表Sub 深度隱藏指定工作表()Sheets("用戶名密碼").Visible = xlVeryHiddenEnd Sub隱藏指定工作表Sub 隱藏指定工作表()Sheets("用戶名密碼").Visible = falseEnd Sub隱藏當(dāng)前工作表Sub 隱藏當(dāng)前工作表() ActiveWindow.SelectedSheets.Visible = falseEnd Sub按光標(biāo)選定顏色隱藏本列其他顏色行Sub 按顏色篩選() '思路就是:其它背景色之行全部隱藏Dim UseRow, AC, i '首先選擇一個(gè)有顏色之單元格，然后動(dòng)行宏，其它顏色所在行隱藏UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)
'表示已用區(qū)域最后一個(gè)單元格If ActiveCell.Row > UseRow Then MsgBox "請(qǐng)?jiān)谝Y選的區(qū)域選擇一個(gè)有顏色之單元格！", vbExclamation, "錯(cuò)誤"Else AC = ActiveCell.Column Cells.EntireRow.Hidden = False '顯示所有行 For i = 2 To UseRow If Cells(i, AC).Interior.ColorIndex <> ActiveCell.Interior.ColorIndex Then Cells(i, AC).EntireRow.Hidden = True '如果2至已用行之單元格的有列之顏色不等于當(dāng)前單元格顏色則隱藏整行 End If NextEnd IfEnd Sub打開(kāi)工作簿自動(dòng)隱藏錄入表以外的其他表Private Sub Workbook_Open()Dim iFor i = 1 To Sheets.CountIf Sheets(i).Name <> "錄入" ThenSheets(i).Visible = FalseEnd IfNextEnd Sub除最左邊工作表外深度隱藏所有表Sub 除最左邊工作表外深度隱藏所有表()For i = 2 To ThisWorkbook.Sheets.Count Sheets(i).Visible = xlSheetVeryHiddenNextEnd Sub關(guān)閉文件時(shí)自動(dòng)隱藏指定工作表(ThisWorkbook)Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect Sheets("Sheet2").Visible = False Sheets("Sheet3").Visible = FalseActiveWorkbook.Protect Structure:=True, Windows:=FalseEnd Sub打開(kāi)文件時(shí)提示指定工作表是保護(hù)狀態(tài)(ThisWorkbook)Private Sub Workbook_Open()If Worksheets("Sheet1").ProtectContents = True Then MsgBox " Sheet1 保護(hù)了."End IfEnd Sub插入10行Sub 插入10行() Rows(ActiveCell.Row & ":" & ActiveCell.Row + 9).Select Selection.Insert Shift:=xlDownEnd Sub全選固定范圍內(nèi)小于0的單元Sub 全選固定范圍內(nèi)小于0的單元()Dim rng As RangeDim yvhfFor Each rng In Range("d6: i18")If rng < 0 Thenyvhf = yvhf & rng.Address & ","End IfNextRange(Left(yvhf, Len(yvhf) - 1)).SelectEnd Sub全選選定范圍內(nèi)小于0的單元Sub 全選選定范圍內(nèi)小于0的單元()Dim rng As RangeDim yvhfFor Each rng In SelectionIf rng < 0 Thenyvhf = yvhf & rng.Address & ","End IfNextRange(Left(yvhf, Len(yvhf) - 1)).SelectEnd Sub固定區(qū)域單元分類變色Sub 單元分類變色()Dim rng As RangeFor Each rng In Range("d6: i18")If rng < 0 Thenrng.Interior.ColorIndex = 4 '小于0的單元變綠底色End IfNextFor Each rng In Range("d6: i18")If rng > 0 Thenrng.Interior.ColorIndex = 3 '文本、假空和大于0的單元變紅底色End IfNextFor Each rng In Range("d6: i18")If rng = 0 Thenrng.Interior.ColorIndex = 2 '空值和等于0的單元變白底色End IfNextEnd SubA列半角內(nèi)容變紅Sub A列半角內(nèi)容變紅() Dim rg As Range, i As Long Application.ScreenUpdating = False For Each rg In Cells.SpecialCells(xlCellTypeConstants, 3) For i = 1 To Len(rg) If Asc(Mid(rg, i, 1)) > 0 Then rg.Characters(i).Font.ColorIndex = 3 Next Next Application.ScreenUpdating = TrueEnd Sub單元格錄入數(shù)據(jù)時(shí)運(yùn)行宏的代碼Private Sub Worksheet_Change(ByVal Target As Range)重排窗口End Sub焦點(diǎn)到A列時(shí)運(yùn)行宏的代碼Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 Then宏名 End IfEnd Sub根據(jù)B列最后數(shù)據(jù)快速合并A列單元格的控件代碼Private Sub CommandButton1_Click()For i = 1 To [b65536].End(xlUp).Row For j = i + 1 To [b65536].End(xlUp).Row If Range("a" & j) = "" Then Range("a" & i & ":a" & j).Merge Else Exit For End If Next jNext iEnd Sub在F1單元顯示光標(biāo)位置批注內(nèi)容的代碼Private Sub Worksheet_SelectionChange(ByVal Target As Range)a = Selection.Addressb = Range(a).NoteTextCells(1, 6) = bEnd Sub顯示光標(biāo)所在單元的批注的代碼Dim r As RangePrivate Sub Worksheet_SelectionChange(ByVal Target As Range)On Error Resume Nextr.Comment.Visible = FalseSet r = Targetr.Comment.Visible = TrueEnd Sub使單元內(nèi)容保持不變的工作表代碼Private Sub Worksheet_Change(ByVal Target As Range)[B2] = "不可更改的數(shù)據(jù)"End Sub有條件執(zhí)行宏Sub 高級(jí)篩選()If [J1] = 2 Or [K1] = "篩選" Then Columns("D:E").Select Selection.Clear Range("D1").Select Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "G1:G2"), CopyToRange:=Range("D1"), Unique:=FalseEnd IfEnd Sub有條件執(zhí)行不同的宏Sub 有條件執(zhí)行不同的宏() If [b1].Value = "A" Then Application.Run "宏1"ElseIf [b1].Value = "B" Then Application.Run "宏2"End IfEnd Sub提示確定或取消執(zhí)行宏Sub 提示確定或取消執(zhí)行宏()If vbOK = MsgBox("確定要復(fù)制嗎?", vbOKCancel) ThenRange("A4:A14").Copy Range("b4:b14")End IfMsgbox "復(fù)制結(jié)束"End Sub提示開(kāi)始和結(jié)束 Sub 提示結(jié)束()Msgbox "運(yùn)行開(kāi)始" 過(guò)程……Msgbox "運(yùn)行結(jié)束"End Sub拷貝指定表不相鄰多列數(shù)據(jù)到新位置Sub 拷貝指定表不相鄰多列數(shù)據(jù)到新位置()Sheets("sheet1").Range("A:A,J:J").Copy Range("d1")End Sub選擇2至4行Sub 選擇2至4行() Dim a As Integer Dim b As Integer a = 2 b = 4 Rows(a & ":" & b).SelectEnd Sub在當(dāng)前選區(qū)有條件替換數(shù)值為文本Sub 在當(dāng)前選區(qū)有條件替換數(shù)值為文本()For Each r In Selection If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y"NextEnd Sub自動(dòng)篩選全部顯示指定列Sub 自動(dòng)篩選全部顯示指定列()Selection.AutoFilter Field:=1Selection.AutoFilter Field:=2Selection.AutoFilter Field:=3Selection.AutoFilter Field:=4Selection.AutoFilter Field:=5Selection.AutoFilter Field:=6End Sub全部顯示指定表的自動(dòng)篩選Sub 全部顯示指定表的自動(dòng)篩選()If Sheet1.FilterMode = True Then Sheet1.ShowAllDataEnd IfEnd Sub強(qiáng)行合并單元Sub 強(qiáng)行合并單元() Application.DisplayAlerts = False '不出現(xiàn)對(duì)話框，按對(duì)話框默認(rèn)選擇 Range("a3:a4").Merge Application.ScreenUpdating = TrueEnd Sub指定A列的日期格式Sub 指定A列的日期格式()[a:a].NumberFormat = "yyyy.mm.dd"End Sub在所有工作表的A1單元返回順序號(hào)Sub 在所有工作表的A1單元返回順序號(hào)()For i = 1 To Sheets.CountSheets(i).Cells(1, 1) = "'" & Application.WorksheetFunction.Text(0 + i, "000")NextEnd Sub根據(jù)A1單元內(nèi)容返回C1數(shù)值Sub 根據(jù)A1單元內(nèi)容返回C1數(shù)值()If Range("A1") = "A" Then Range("C1").FormulaR1C1 = "結(jié)算" ElseIf Range("A1") = "B" Then Range("C1").FormulaR1C1 = "合計(jì)" ElseIf Range("A1") = "C" Then Range("C1").FormulaR1C1 = "部門" End IfEnd Sub根據(jù)A1內(nèi)容選擇執(zhí)行宏Sub 根據(jù)A1內(nèi)容選擇執(zhí)行宏() Select Case Sheet1.[A1] Case "A" 宏1 Case "B" 宏2 Case "C" 宏3 Case Else End SelectEnd Sub刪除A列空行Sub 刪除A列空行()Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.DeleteEnd Sub在A列產(chǎn)生不重復(fù)隨機(jī)數(shù)Sub 在A列產(chǎn)生不重復(fù)隨機(jī)數(shù)() Randomize Timer Dim c(100) As Byte For i = 1 To 100 '產(chǎn)生100個(gè)隨機(jī)數(shù) c(i) = i Next k = 100 Do While l < 100 r = Int(Rnd() * k) + 1 '隨機(jī)數(shù)的范圍 aa = c(r) c(r) = c(k) c(k) = aa k = k - 1 l = l + 1 Cells(l, 1) = aaLoopEnd Sub將A列數(shù)據(jù)隨機(jī)排列到F列Sub 將A列數(shù)據(jù)隨機(jī)排列到F列()Dim n As Longn = [a65536].End(xlUp).Row[f1].Resize(n, 1) = [a1].Resize(n, 1).Value[g1].Resize(n, 1) = "=rand()"[f:g].Sort [g1][g:g] = ""End Sub取消選定區(qū)域的公式只保留值(假空轉(zhuǎn)真空)Sub 取消選定區(qū)域的公式只保留值() ' Sheets("數(shù)據(jù)歸并集中").Select '指定工作表 ' Columns("Q:R").Select '指定范圍Selection.Value = Selection.ValueEnd Sub處理導(dǎo)入的顯示為科學(xué)計(jì)數(shù)法樣式的身份證號(hào)Sub 處理導(dǎo)入的顯示為科學(xué)計(jì)數(shù)法樣式的身份證號(hào)()Selection.Value = Selection.FormulaEnd Sub返回指定單元的行高和列寬Sub 返回指定單元的行高和列寬()[c2] = Range("A1").ColumnWidth '列寬[b2] = Range("A1").RowHeight '行高End SubSub 返回指定單元的行高和列寬() Dim r%, c% r = [a1].RowHeight c = [a1].ColumnWidth [b2] = r '行高 [c2] = c '列寬End Sub指定行高和列寬Sub 指定行高和列寬() Range("A1:F1").ColumnWidth = 10 '指定列寬 Range("A2:A10").RowHeight = 40 '指定行高End SubSub 指定行高和列寬() Columns("A:F").ColumnWidth = 10 '指定列寬 Rows("2:10").RowHeight = 40 '指定行高End Sub指定單元的行高和列寬與A1單元相同Sub 指定單元的行高和列寬與A1單元相同() Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth '指定列寬 Range("A2:A10").RowHeight = Range("A1").RowHeight '指定行高End Sub填公式Sub 填公式()Range("C2:C12").Value = "=SUM(A2:B2)"End Sub建立當(dāng)前工作表的副本為001表Sub 建立當(dāng)前工作表的副本為001表() ActiveSheet.Copy Before:=Sheets(1) ActiveSheet.Name = "001"End Sub插入新表Sub 插入新表()Sheets.AddEnd Sub清除A列再插入序號(hào)Sub 清除A列再插入序號(hào)()'Columns(1).ClearContents '清除A列內(nèi)容For i = 1 To 20Range("a" & i) = iNextEnd Sub反方向文本(自定義函數(shù))Function zhyz(zhyz1 As Range)zhyz = StrReverse(zhyz1)End Function將代碼復(fù)制到模塊后單元公式：=zhyz(單元格)指定選擇單元區(qū)域彈出消息Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = "$A$1:$C$3" Then MsgBox "你選擇對(duì)了"End IfEnd Sub將B列數(shù)據(jù)添加超鏈接到K列Sub 將B列數(shù)據(jù)添加超鏈接到K列() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row) ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:="",
SubAddress:=Sheet1.Range("K" & Rng.Row).Address, ScreenTip:="點(diǎn)擊轉(zhuǎn)到:" & Sheet1.Name & "K" & Rng.Row NextEnd Sub刪除B列數(shù)據(jù)的超鏈接Sub 刪除超鏈接() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row) Sheet1.Range(Rng.Address).Hyperlinks.Delete NextEnd Sub分離臨時(shí)表A列數(shù)據(jù)的文本和超鏈接并整理到數(shù)據(jù)庫(kù)表Sub 分離A列中的超鏈接到指定表的B和C列()i = Worksheets("數(shù)據(jù)庫(kù)").Range("b60000").End(xlUp).RowFor Each h In Worksheets("臨時(shí)").HyperlinksWorksheets("數(shù)據(jù)庫(kù)").Cells(i + 1, 2) = h.TextToDisplayWorksheets("數(shù)據(jù)庫(kù)").Cells(i + 1, 3) = h.AddressRange(Worksheets("數(shù)據(jù)庫(kù)").Cells(i + 1, 3), Worksheets("數(shù)據(jù)庫(kù)").Cells(i + 1, 3))
.Hyperlinks.Add Anchor:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)i = i + 1NextEnd Sub分離臨時(shí)表A列數(shù)據(jù)的文本和超鏈接并會(huì)同其他數(shù)據(jù)整理到數(shù)據(jù)庫(kù)表Sub 分離A列數(shù)據(jù)的文本和超鏈接并會(huì)同其他數(shù)據(jù)整理到指定表() ier = Worksheets("數(shù)據(jù)庫(kù)").Range("b60000").End(xlUp).RowFor ee = 5 To Range("a60000").End(xlUp).RowFor Each hh In Worksheets("臨時(shí)").HyperlinksIf hh.TextToDisplay = Cells(ee, 1) And Cells(ee, 1) <> "" Thenwww = www & "," & ee End IfNextNextwww = Right(www, Len(www) - 1)zxc = Split(www, ",") For sd = 0 To UBound(zxc) - 1 For wee = zxc(sd) + 1 To zxc(sd + 1) - 1 Worksheets("數(shù)據(jù)庫(kù)").Cells(sdf + ier + 1, uu + 4) = Cells(wee, 1) uu = uu + 1 Next sdf = sdf + 1 uu = 0 NextFor Each hhh In Worksheets("臨時(shí)").Range("A6:A6000").HyperlinksWorksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 2) = hhh.TextToDisplayWorksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 3) = hhh.AddressRange(Worksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 3), Worksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 3)).Hyperlinks
.Add Anchor:=Worksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 3), Address:=Worksheets("數(shù)據(jù)庫(kù)").Cells(ier + 1, 3)ier = ier + 1NextEnd Sub返回A列非空單元行號(hào)Sub 返回A列非空單元行號(hào)()MsgBox Cells.Range("A65536").End(xlUp).RowEnd Sub返回表中第一個(gè)非空單元地址(行搜索)Sub 返回表中第一個(gè)非空單元地址()MsgBox Cells.Find("*").AddressEnd Sub返回表中各非空單元區(qū)域地址(行搜索)Sub 返回表中各非空單元區(qū)域地址()MsgBox Cells.SpecialCells(2).AddressEnd Sub返回非空單元數(shù)量Sub 返回非空單元數(shù)量()x = Application.CountA(Range("A1:Z65536"))MsgBox xEnd Sub返回A列非空單元數(shù)量Sub 返回A列非空單元數(shù)量()y = Application.CountA(Columns(1))MsgBox yEnd Sub返回圓周率πSub Macro1()Range("A1") = Application.Pi()End Sub定義指定單元內(nèi)容為頁(yè)眉/頁(yè)腳Sub 定義指定單元內(nèi)容為頁(yè)眉/頁(yè)腳()BBB = Sheets("表1").Range("A2") With ActiveSheet.PageSetup .CenterHeader = BBB '定義頁(yè)眉 ' .CenterFooter = BBB '定義頁(yè)腳 End WithEnd Sub
本站僅提供存儲(chǔ)服務(wù)，所有內(nèi)容均由用戶發(fā)布，如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容，請(qǐng)
點(diǎn)擊舉報(bào)。
