带vba代码的xlsm文件怎么用python vba 代码

转载

mob64ca14106f2f 2024-05-29 00:57:02

工作表操作

' 关闭警告，否则删除工作表时将出现提示信息
Application.DisplayAlerts = False

' 删除以字母“C”开头的临时模板
For Each a In Worksheets
  If Left(a.Name, 1) = "C" Then a.Delete
  ' If InStr(a.Name, ".") > 0 Then a.Delete
Next

' 复制工作表到最后并重新命名，注意：新工作表将成为当前工作表，如果使用 ActiveSheet 引用其它工作表中的单元格将可能发生引用错误
n = Worksheets.Count
ActiveSheet.Copy after:=Sheets(n)
' 直接使用 ActiveSheet 更方便
' Worksheets(n + 1).Name = "C22"
ActiveSheet.Name = "C22"

' 将“校内”工作表复制到最后并重新命名
Sheets("校内").Copy After:=Sheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "工作表标题"

' 取得前一工作表的名称并指定给当前工作表
Application.ActiveSheet.Name = Sheets(Application.ActiveSheet.Index - 1).Name

ActiveSheet.Unprotect Password:="123456"
' 为防止用户更改，模板工作表加了保护，取消保护后可以对表中内容进行更改
ActiveSheet.Protect Password:="123456"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

' 开启警告
Application.DisplayAlerts = True

工作簿操作

' 返回路径及工作簿文件名
Application.ActiveWorkbook.FullName    

' 只返回路径
Application.ActiveWorkbook.Path    

' 返回工作簿文件名 
Application.ActiveWorkbook.Name 

' 当前文件另存为一副本，而且不把当前文件切换到副本上
ActiveWorkbook.SaveCopyAs (ActiveWorkbook.Path & "\" & aFileName & ".xls")  

' 不保存修改，重新打开当前工作簿
Filename = ActiveWorkbook.FullName
ActiveWorkbook.Close (False)
Workbooks.Open (Filename)

打开当前目录下的多个工作簿查找指定值

Dim wb As Workbook
Dim ws, desSheet As Worksheet
Dim r As Range
    
' 保存目标工作表
Set desSheet = ActiveSheet

For i = 1 To 13
    ' 打开工作簿必须以绝对全路径指示文件名，只写文件名将导致错误
    sFilename = ThisWorkbook.Path & "\N" & (i + 2006) & ".xls"

    ' 对象变量必须以 set 赋值，不可省略
    Set wb = Workbooks.Open(sFilename)

    ' 对工作簿内所有工作表进行搜索
    For Each ws In wb.Worksheets
        ' xlPart 部分匹配，可防止目标单元格中包含多余的空格
        Set r = ws.Cells.Find(what:="人均地区生产总值", lookat:=xlPart)
        If Not r Is Nothing Then
           MsgBox ("在工作表 " & r.Worksheet.Name & " 第 " & r.Row & " 行，第 " & r.Column & " 列查找到！")
           Exit For ' 不再搜索其余工作表
        End If
    Next
    wb.Close
Next i

单元格操作

' 清除单元格内容
Sheets("tmp").Columns("A:D").ClearContents

' 选择性粘贴，Cells(行座标，列座标）
Range(Cells(FirstVisibleRow + 39, 3), Cells(FirstVisibleRow + RowCount - 1, 4)).Copy
Sheets("out").Range("k4").PasteSpecial Paste:=xlPasteValues

' 选择性粘贴，粘贴为“值”并行列转置
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=True

' 设置单元格数字格式为两位小数
Range("J" & (rownum + 2)).NumberFormatLocal = "0.00" 

' 设置单元格数字格式为百分号前两位小数
Range("J" & (rownum + 2)).NumberFormatLocal = "0.00%" 

' 区域数据拷贝
Sheet1.Range("A1:D4").Copy Destination:=Sheet3.Range("b3")

' 当前单元格内容
Selection.Value

' 取显示的数值而不是公式
range.text

' 取消复制
Application.CutCopyMode = False '注意是application
Range("A5").Select

排序

' 排序
Selection.Sort Key1:=Range("B9"), Order1:=xlAscending,Header:=xlGuess, _
	OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
	:=xlPinYin

' 区域内排序
Range("A3:G13").Select
Selection.Sort Key1:=Range("E4"), Order1:=xlDescending, Header:=xlGuess, _
	OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
	:=xlPinYin

筛选

' 自动筛选
Worksheets("Sheet1").Range("A1").AutoFilter _
    field:=1, _
    Criteria1:="Otis", VisibleDropDown:=False

' 显示全部
Worksheets("Sheet1").ShowAllData

' 取消筛选
If Worksheets("Sheet1").FilterMode = True Then
  Worksheets("Sheet1").ShowAllData
End If

' 高级筛选
' 源数据所在区域，本例中为另一数据表 sheet1
Sheets("Sheet1").Range("A1:D11").AdvancedFilter Action:=xlFilterCopy, _
    ' 筛选条件及筛选结果区域，都在 sheet2 中
    CriteriaRange:=Range("B1:B2"), CopyToRange:=Range("B6"), Unique:=False

公式

' 求和公式，注意有 FormulaR1C1 和 Formula 两种属性，使用行列名称写公式时必须使用 Formula 属性。
Sheet1.Cells(2, 2).FormulaR1C1 = "=SUM(R1C1:R4C1)" 
Sheet1.Cells(2, 2).Formula = "=SUM(A1:A4)" 

' 填入求和公式
Sheet2.Cells(iFlag, i).value = "=SUM(R" & format(iBegin) & "C" & format(i) & _
         ":R" & format(iEnd) & "C" & format(i) & ")"

' 向单元格填充公式，注意数字转换成字符串时要使用 format 函数(or "CStr")。
Sheet1.Cells(15, 3).Value = "=SUM(" & "c" & Format(5) & ":c" & Format(14) & ")"

' 填入R1C1格式公式
Cells(i, 9).FormulaR1C1 = "=RC[-3]+RC[-2]+RC[-1]" 
' 注：R[-1]表示上一行，R[+1]表示下一行；C[-1]表示前一列，C[+1]表示下一列

' 公式的拖拉填充

' 将 C1 单元格的公式横向拖拉填充到 C1:F1 区域
Range("C1:C1").AutoFill Destination:=Range("C1:F1"), Type:=xlFillDefault

' 将 C1:F1 区域（一行）的公式纵向拖拉填充 7 行到 C1:F7 区域
Range("C1:F1").AutoFill Destination:=Range("C1:F7"), Type:=xlFillDefault

行操作

' 插入空行
Selection.EntireRow.Insert    '在当前行之前插入行
Rows(5).EntireRow.Insert    '在第五行之前插入行，新的空白行成为第五行

' 选择并删除指定行
Rows("784:784").Select
Selection.Delete Shift:=xlUp

' 直接删除指定行
Rows(i).Delete Shift:=xlUp

' 取得已经使用的行数
ActiveSheet.UsedRange.Rows.Count

' 设置行高
Rows("4:4").RowHeight = 21

列操作

' 隐藏列
Columns("B:B").Select
Range("B2").Activate
Selection.EntireColumn.Hidden = True

' 某列是否隐藏
If Sheet1.Columns(2).Hidden = True Then

' 显示隐藏的列
Range.EntireColumn.Hidden = False

' 取得已经使用的列数
ActiveSheet.UsedRange.Columns.Count

' 插入列
Selection.EntireColumn.Insert    '在当前列之前插入列
Columns(4).EntireColumn.Insert    '在第四列之前插入列，新的空白列成为第四列

' 设置列宽
Selection.Columns.AutoFit        '最适合列宽
Selection.ColumnWidth = 7.25    '固定宽度（单位：磅）

' 清除几列内容
Columns("A:D").ClearContents

打印

' 插入水平分页符
ActiveSheet.HPageBreaks.Add before:=ActiveCell   '在当前行之上插入分页符
ActiveSheet.HPageBreaks.Add before:=Cells(6, 1)  '在第6行之上插入分页符，列值（1）无实际意义，可以任意设置

' 例程：检测第 5 列的值，发现新的值时自动分页，并在第一列写入序号

KeyCol = 3 ' 根据第5列值，发生变化时插入水平分页符
StartDataRow = 2 '数据开始行，注意：跳过标题栏
num = 1 ' 序号值，写入第一列

LastRw = ActiveSheet.UsedRange.Rows.Count

' 从数据行开始查找
For x = StartDataRow To LastRw
  ' 在第一列写入序号
  Cells(x, 1).Value = num
  If Cells(x + 1, KeyCol) <> Cells(x, KeyCol) Then
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(x + 1, 1)
    num = 1
  Else
    num = num + 1
  End If
Next

' 插入垂直分页符
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=ActiveCell

' 设置顶端标题行
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$2"  '第一行和第二行作为标题行
        .PrintTitleColumns = ""
    End With

' 设置打印区域
ActiveSheet.PageSetup.PrintArea = "$B$4:$D$11"

交互操作

' 输入对话框

Dim sDate As String
sDate = InputBox("请输入制表月份，例：2005-2", "制表月份", Format(Date, "yyyy-m"))
If sDate = "" Then End
MsgBox (sDate)

取得表中最后的数据行号

Function GetLastRow(Col, startRow)
    Dim lngLastRow As Long
    Dim i, currentRow As Long
    '获取工作表中已使用区域最后一行的行号
    lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    i = startRow
    Do While (Not IsEmpty(Cells(i, Col)))
        currentRow = i
        i = i + 1
    Loop
    GetLastRow = currentRow
End Function

删除公式结果中的 #N/A

将下列代码写在 VBA 模块中，就可以在单元格公式中引用。例如：原先使用 =VLOOKUP($A$3,转入!$A$2:$G$73,2,FALSE) 有可能导致　#N/A 的结果，那么改成 =REMOVENA(VLOOKUP($A$3,转入!$A$2:$G$73,2,FALSE)) 就可以得到 0 值。

' 自定义函数，用于在工作表中调用，可以防止 LookUp 函数生成 #N/A 结果
Function RemoveNA(VarIn)
  If Application.WorksheetFunction.IsNA(VarIn) Then
    RemoveNA = 0
  Else
    RemoveNA = VarIn
  End If
End Function

根据总表中的班级分别复制成新的工作表并重命名

' 根据总表中的班级分别复制成新的工作表并重命名
    
    srcRow = 2  '来源表起始行
    keyCol = 2  '来源表班级号所在列，列值变化时生成新工作表
    currentClass = 0
    newClass = Sheets("stu").Cells(srcRow, keyCol).Value + 0    ' 转数字
    While newClass <> 0                                         ' 来源表未到尾
        If newClass <> currentClass Then                        ' 新班级
            currentClass = newClass
            desRow = 3
        Else
            Sheets("校内").Copy After:=Sheets(Worksheets.Count)  ' 复制工作表模板
            Title = Sheets("stu").Cells(srcRow, 1).Value & "年" & Sheets("stu").Cells(srcRow, 2).Value & "班"
            While (Sheets("stu").Cells(srcRow, keyCol).Value + 0) = currentClass
                Worksheets(Worksheets.Count).Cells(desRow, 2).Value = Sheets("stu").Cells(srcRow, 3).Value
                desRow = desRow + 1
                srcRow = srcRow + 1
            Wend
            Worksheets(Worksheets.Count).Name = Title                   ' 设置工作表标题
            Worksheets(Worksheets.Count).Cells(3, 3).Value = Title      ' 当前工作表中单元格的值
            newClass = Sheets("stu").Cells(srcRow, keyCol).Value + 0    ' 下一班级号
            
        End If
    Wend

本文章为转载内容，我们尊重原作者对文章享有的著作权。如有内容错误或侵权问题，欢迎原作者联系我们进行内容更正或删除文章。