vba实用操作代码

1、vba制作目录

Sub mulu()
    MsgBox "下面将为工作薄中所有工作表建立目录!"
    Rows("2:65536").ClearContents                    '清除工作表中原有数据
    Dim sht As Worksheet, irow As Integer
    irow = 2                                         '在第2行写入第一条记录
    For Each sht In Worksheets                       '遍历工作表
        Cells(irow, "A").Value = irow - 1            '写入序号
        '写入工作表名，并建立超链接
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(irow, "B"), Address:="", _
             SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
        irow = irow + 1                              '行号加1
    Next
End Sub

1.2顺序新建工作表

Sub 创建表格()
Application.ScreenUpdating = False
r = [a1].CurrentRegion
For i = 1 To UBound(r)
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = r(i, 1)
Next
Application.ScreenUpdating = True
End Sub

1.3根据名称在文件夹下新建工作簿

Sub 创建工作簿()
Application.ScreenUpdating = False
r = [a1].CurrentRegion
For i = 1 To UBound(r)
    With Workbooks.Add
        .SaveAs ThisWorkbook.Path & "/" & r(i, 1) & ".xlsx"
        .Close False
    End With
Next
Application.ScreenUpdating = True
End Sub

2、汇总工作表格数据到第一个工作表

Option Explicit
Sub hebing()
    MsgBox "下面将把各班成绩表合并到“总成绩”工作表中!"
    Rows("2:65536").Clear                                       '删除原有记录
    Dim sht As Worksheet, xrow As Integer, rng As Range
    For Each sht In Worksheets                                  '遍历工作薄中所有工作表
        If sht.Name <> ActiveSheet.Name Then
            Set rng = Range("A65536").End(xlUp).Offset(1, 0)    '获得汇总表A列第一个空单元格
            xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '获得分表中的记录条数
            sht.Range("A2").Resize(xrow, 7).Copy rng            '粘贴记录到汇总表
        End If
    Next
End Sub

3、设置单元格格式

Option Explicit

Sub FontSet()
Cells.ClearFormats
'标题文字

    With Range("A2").CurrentRegion.Borders
        .LineStyle = xlContinuous                  '设置单线边框
        .Color = vbBlack                    '设置边框的颜色黑色
        .Weight = xlThin                        '设置边框线条样式
    End With
    With Range("A2").CurrentRegion.Font
       .Name = "宋体"                                  '设置字体为宋休
         .Size = 17                                    '设置字号为12号
         .Color = vbBlack                        '设置字体颜色为黑色
         .Bold = False                                   '设置字体加粗
         .Italic = False                                  '设置文字倾斜不显示
    End With

  With Range("A2").CurrentRegion
  .RowHeight = 50                              '所有单元格行高为50
  .HorizontalAlignment = Excel.xlCenter        '所有单元格水平对齐
  .VerticalAlignment = xlCenter                '所有单元格竖向对齐
  .WrapText = True                             '所有单元格自动换行
  End With


    Range("A1:F1").Merge                                '标题单元格合并
     With Range("A1:F1").Font
         .Name = "宋体"                                  '设置字体为宋休
         .Size = 27                                    '设置字号为12号
         .Color = vbBlack                        '设置字体颜色为黑色
         .Bold = True                                    '设置字体加粗
         .Italic = False                                  '设置文字倾斜不显示
    End With

End Sub

4、汇总同一文件夹下所有的工作簿

Sub HzWb()
    Dim bt As Range, r As Long, c As Long
    r = 1    '1 是表头的行数
    c = 8    '8 是表头的列数
    Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents    ' 清除汇总表中原表数据
    Application.ScreenUpdating = False
    Dim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xls")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then    ' 判断文件是否是本工作簿
            Erow = Range("A1").CurrentRegion.Rows.Count + 1    ' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName
            Set wb = GetObject(fn)    ' 将fn 代表的工作簿对象赋给变量
            Set sht = wb.Worksheets(1)    ' 汇总的是第1 张工作表
            ' 将数据表中的记录保存在arr 数组里
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))
            ' 将数组arr 中的数据写入工作表
            Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            wb.Close False
        End If
        FileName = Dir    ' 用Dir 函数取得其他文件名，并赋给变量
    Loop
    Application.ScreenUpdating = True
End Sub

5、合并单元格

Sub MergeRange()
    Dim Rng As Range
    Dim i&, Col&, Fist, Last
    Set Rng = Application.InputBox("请选择单列数据列！", Type:=8)
    '用户选择数据列
    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
    'intersect语句避免用户选择整列造成无谓运算
    Col = Rng.Column 'Rng所在列
    Fist = Rng.Row
    'Rng开始行，用户选择的区域并不是一定从第一行开始，因此需要此句判断
    Last = Fist + Rng.Rows.Count - 1 'Rng结束行
    Application.ScreenUpdating = False '取消屏幕更新
    Application.DisplayAlerts = False
    '取消消息提醒。当有值单元格被合并时屏蔽提示信息
    Rng.Parent.Select '激活Rng对象所在的工作表，避免跨工作表操作问题
    For i = Last To Fist + 1 Step -1
    '对Rng进行从后向前遍历
        If Cells(i, Col) = Cells(i - 1, Col) Then
            Cells(i - 1, Col).Resize(2, 1).Merge
        End If
    Next
    Rng.VerticalAlignment = xlCenter '格式上下居中
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "合并完成。"
End Sub

6、拆分单元格

Sub ubMergeRange() '拆分单元格
    Dim Rng As Range
    Dim i&, Col&, Fist, Last
    Set Rng = Application.InputBox("请选择单列数据列！", Type:=8)
    '用户选择数据列
    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
    'intersect语句避免用户选择整列造成无谓运算

    On Error Resume Next
    Rng.Parent.Select '激活Rng对象所在的工作表，避免跨工作表操作问题
    Rng.UnMerge
    Rng.SpecialCells(xlCellTypeBlanks) = "=" & Rng.SpecialCells(xlCellTypeBlanks)(1, 1).Offset(-1).Address(0, 0)
    Rng.Copy: Rng.PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False

    Rng.VerticalAlignment = xlCenter '格式上下居中
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分填充完成。"
End Sub

7、工作簿的工作表合并

Sub 工作薄间工作表合并()


Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")
X = 1
While X <= UBound(FileOpen)
Workbooks.Open Filename:=FileOpen(X)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub

errhadler:
MsgBox Err.Description
End Sub