通用宏

 Public N As Integer
Sub 当前表总行数() 'ActiveSheet.UsedRange.Rows.Count
' 当前表总行数 Macro
' 宏由录制，时间: 2008-8-6
    ActiveSheet.Select
    For i = 65536 To 1 Step -1
    If Cells(i, 1) <> "" Then
       N = i
       'h = MsgBox(i, vbOKOnly, "行数")
       Exit For '退出FOR循环
       'End 退出程序
    End If
    Next i
End Sub
Sub 向下复制选定内容()
' Macro2 向下复制选定内容
' 宏由录制，时间: 2008-8-16
    Application.Run "PERSONAL.XLS!当前表总行数"
    'Dim N As Long
    'N = ActiveSheet.UsedRange.Rows.Count
    Selection.copy
    For i = 1 To N - Selection.Row
       If IsEmpty(ActiveCell.Offset(1, 0)) Then
          ActiveCell.Offset(1, 0).Select
          ActiveSheet.Paste
       Else
          ActiveCell.Offset(1, 0).Select
       End If
    Next i
End Sub
Sub 条件复制()
    Application.Run "PERSONAL.XLS!当前表总行数"
    Selection.copy
    For i = 1 To N - Selection.Row
       If (ActiveCell.Offset(1, 0).Interior.ColorIndex = xlNone) And (ActiveCell.Offset(1, 0).Font.ColorIndex = -4105) Then
          ActiveCell.Offset(1, 0).Select
          ActiveSheet.Paste
       Else
          ActiveCell.Offset(1, 0).Select
       End If
    Next i
End Sub
Sub 选择性数值粘贴()
' 选择性数值粘贴 Macro
' 宏由录制，时间: 2008-8-25
    Cells.Select
    Selection.copy
    Sheets.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub
Sub 复制粘贴()
    Cells.Select
    Selection.copy
    Set NewSheet = Sheets.Add(Type:=xlWorksheet)
    NewSheet.Range("A1").Select
    NewSheet.Paste
    'Cells.Select
    'Selection.copy
    'Sheets.Add
    'ActiveSheet.Paste
End Sub
Sub 提取工作簿()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler              '假如有错,那么跳至ErrHandler 处
ChDrive "f"  'ChDrive Left(ThisWorkbook.FullName, 1)也可  '打开时可直接指向文件所在路径
ChDir ThisWorkbook.Path
  Application.ScreenUpdating = False
      FilesToOpen = Application.GetOpenFilename _
        (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
        MultiSelect:=True, Title:="Files to Merge")      '支持复选
  If TypeName(FilesToOpen) <> "Boolean" Then
    Application.DisplayAlerts = False
    For x = 1 To UBound(FilesToOpen)              '如果不想打开自己
      t$ = t$ & "[" & FilesToOpen(x)
    Next
      If InStr(t$, ThisWorkbook.FullName) Then MsgBox "不可以选择本文件！ ", 16, "提示：": Exit Sub
            x = 1
          While x <= UBound(FilesToOpen)
            Set wk = Application.Workbooks.Open(FilesToOpen(x))
            wk.Sheets(1).Cells.copy ThisWorkbook.Sheets(x).Cells
            x = x + 1
            wk.Close False
          Wend
  Else
    MsgBox "No Files were selected"
  End If
    Application.ScreenUpdating = True
  End              '如果一切正常,那么到这里可以放置全部结束
ErrHandler:
    MsgBox Err.Description  '显示错误类型
End Sub
Sub 生成区域报表()
' Macro1 Macro
' 宏由 Soul 录制，时间: 2008-9-10
Dim nUP As Long
On Error Resume Next '如果出现错误，继续运行下面的代码
zzml = "选择要制作目录的文件夹" '以下代码弹出一个选择文件夹对话框
Set mlzz = CreateObject("Shell.Application").BrowseForFolder(0, zzml, &H1)
lj = mlzz.Self.Path '将选中文件夹的路径传递给变量lj
nSheetname = ActiveSheet.Name
nUP = 7
   For i = 1 To ActiveSheet.UsedRange.Rows.Count
       If (Range("A" & i) <> "") And (Right(Range("A" & i), 2) = "合计") Then
           Sheets(nSheetname).Select
           Sheets(nSheetname).copy Before:=Sheets(1)
           Range("A" & i + 1 & " : IV" & ActiveSheet.UsedRange.Rows.Count).Delete
           Sheets(1).Name = Left(Range("A" & i), Len(Range("A" & i)) - 2)
           Bmstring = Left(Range("A" & i), Len(Range("A" & i)) - 2)
          
           If Sheets(1).Name <> "吕宾区" Then Range("A" & 6 & " : IV" & nUP).Delete
           Sheets(1).Move
           ChDir "D:/桌面"
           ActiveWorkbook.SaveAs FileName:=lj & "/" & Bmstring, FileFormat:=xlNormal, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
            ActiveWindow.Close
            nUP = i
       End If
   Next i
End Sub
Sub 批量单个保存电子表()
    '将同一个文件里的表,独立保存为一个文件
Application.ScreenUpdating = False   '隐藏宏的执行过程
    zzml = "选择要制作目录的文件夹" '以下代码弹出一个选择文件夹对话框
    Set mlzz = CreateObject("Shell.Application").BrowseForFolder(0, zzml, &H1)
    lj = mlzz.Self.Path '将选中文件夹的路径传递给变量lj
   
Start:
   
    N = CVar(InputBox("从第几个表开始复制?", "批量单个保存电子表", 1))
    On Error Resume Next
    If N > Worksheets.Count Then
        MsgBox "请输入少于" & Worksheets.Count & "自然数", vbOKOnly
        GoTo Start
    End If
   
    For i = N To Worksheets.Count
        N_name = Sheets(i).Name         '提取表名作为文件名
        Sheets(i).copy
                                        '指定目标存放文件夹         文件名
        ActiveWorkbook.SaveAs FileName:=lj & "/" & N_name & ".xls", FileFormat:=xlNormal, _
            Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
            CreateBackup:=False
        ActiveWindow.Close
    Next
Application.ScreenUpdating = True

End Sub
Sub 宋体10号()
' Macro1 宋体10号
' 宏由录制，时间: 2008-8-18
    ActiveSheet.Select    'Sheets(ActiveSheet.Name).Select
    With Selection.Font
        .Name = "宋体"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
End Sub
Sub 日期格式()
' Macro8 日期格式(某月某日)
' 宏由 Soul 录制，时间: 2008-8-18
  'ActiveCell.NumberFormatLocal = "m""月""d""日"";@"  单前选中的第一个单元格
  Selection.NumberFormatLocal = "m""月""d""日"";@" '单前选中的所有单元格
End Sub
'移除VBA编码保护调用
'1>一段极好的VBA保护密码破解程序测试WIN98+OFFICE97破解率100%
'2>用以下代码对VBA加密保护后用offkey 6.5-7.0及Advanced VBA pASSWORD Recovery专业版均无法破解出保护程式码的密码
Sub MoveProtect()
  Dim FileName As String
  FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
  If FileName = CStr(False) Then
     Exit Sub
  Else
     VBAPassword FileName, False
  End If
End Sub

'设置VBA编码保护调用
Sub SetProtect()
  Dim FileName As String
  FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
  If FileName = CStr(False) Then
     Exit Sub
  Else
     VBAPassword FileName, True
  End If
End Sub
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False) '设置与移除VBA编码保护
    If Dir(FileName) = "" Then
       Exit Function
    Else
       FileCopy FileName, FileName & ".bak"
    End If
    Dim GetData As String * 5
    Open FileName For Binary As #1
    Dim CMGs As Long
    Dim DPBo As Long
    For i = 1 To LOF(1)
        Get #1, i, GetData
        If GetData = "CMG=""" Then CMGs = i
        If GetData = "[Host" Then DPBo = i - 2: Exit For
    Next
    
    If CMGs = 0 Then
       MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
       Exit Function
    End If
    
    If Protect = False Then
       Dim St As String * 2
       Dim s20 As String * 1
       
       '取得一个0D0A十六进制字串
       Get #1, CMGs - 2, St
    
       '取得一个20十六制字串
       Get #1, DPBo + 16, s20
    
       '替换加密部份机码
       For i = CMGs To DPBo Step 2
           Put #1, i, St
       Next
       
       '加入不配对符号
       If (DPBo - CMGs) Mod 2 <> 0 Then
          Put #1, DPBo + 1, s20
       End If
       MsgBox "文件解密成功......", 32, "提示"
    Else
       Dim MMs As String * 5
       MMs = "DPB="""
       Put #1, CMGs, MMs
       MsgBox "对文件特殊加密成功......", 32, "提示"
    End If
    Close #1
End Function
Sub 生成部门利润表()
On Error Resume Next '如果出现错误，继续运行下面的代码
zzml = "选择要制作目录的文件夹" '以下代码弹出一个选择文件夹对话框
Set mlzz = CreateObject("Shell.Application").BrowseForFolder(0, zzml, &H1)
lj = mlzz.Self.Path '将选中文件夹的路径传递给变量lj
ActiveWorkbook.SaveCopyAs lj & "/" & ActiveWorkbook.Name
BMcount = 0
littlesection = Range("ID!B2").Value
RowCount = [ID!C65536].End(xlUp).Row
For i = 2 To RowCount
    '建立文件夹
    If Range("ID!A" & i).Value <> "" Then
        packnamesting = Range("ID!A" & i).Value
        MkDir lj & "/" & packnamesting
        largesection = Range("ID!A" & i).Value
        littlesection = Range("ID!B" & i).Value
    End If
    '复制利润表
    If Range("ID!D" & i).Value <> "" Then
        Sheets("aa").copy Before:=Sheets(1)
        Sheets(1).Name = Range("ID!C" & i).Value
        BMcount = BMcount + 1
    End If
    '保存为独立文件
    If Range("ID!B" & i + 1).Value <> "" Or i = RowCount Then
        '命名及保存文件
            ActiveWorkbook.SaveCopyAs lj & "/" & packnamesting & "/" & littlesection & ".xls"
            Workbooks.Open FileName:=lj & "/" & packnamesting & "/" & littlesection & ".xls"
        '删除多余的工作表
            Application.DisplayAlerts = False
            For l = BMcount + 1 To Sheets.Count
                Sheets(Sheets.Count).Delete
            Next
            ActiveWorkbook.Save
            ActiveWindow.Close
            For N = 1 To BMcount
                Sheets(1).Delete
            Next
            Application.DisplayAlerts = True
            littlesection = Range("ID!B" & i + 1).Value
            BMcount = 0
    End If
Next
End Sub