zhimiaoli

/**
 * The first commented line is your dabblet’s title
 */

background: #f06;
background: linear-gradient(45deg, #f06, yellow);
min-height: 100%;

zhimiaoli

.markdown-body {
    font-size: 14px;
    line-height: 1.6;
}
.markdown-body > *:first-child {
    margin-top: 0 !important;
}
.markdown-body > *:last-child {
    margin-bottom: 0 !important;
}

zhimiaoli

Function tax(salary As Double) As Double
Application.Volatile '让Excel频繁计算，避免更改工资还不更新个税
'''个人所得税计算函数
    
    If salary < 3500 Then
        tax = 0
    Else
        g = salary - 3500
        Select Case g
            Case Is <= 1500

zhimiaoli

Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
''''''''''''''
'这个宏的功能是清空剪贴板，当复制东西的时候，然后要插入什么，不能单纯的插入，只能插入复制的内容
'这个宏就是清空剪贴板，让你可以插入空白
'清空剪贴板，需要上面的声明。
'参考http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=767916&pid=5233159
''''''''''''''
Sub clearClipboard() 

zhimiaoli

Sub createhyperlink()
'
' 将选中的表格，链接到标题为表格内容中的表。
' 举个列子，如果单元格的内容是foo，就会把这个表格链接到foo表。
'
 
'
On Error Resume Next
For Each celln In Selection
    celln.Select

zhimiaoli

Sub createPageBreak()
'创建分页
'在小计后面添加手动分页

For i = 1 To 10000  '只到10000行
If Cells(i, 1) = "小计" Then '设置分行内容
   Cells(i, 1).Select
    ActiveCell.Offset(1, 1).Rows("1:1").EntireRow.Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End If

zhimiaoli

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim msg As Outlook.MailItem
    Dim favAcctName As String
    On Error Resume Next
    If TypeOf Item Is Outlook.MailItem Then
        favAcctName = Application.Session.Accounts(1).DisplayName '定义不检查的邮箱地址
        Set msg = Item
        If msg.SendUsingAccount <> favAcctName Then
        res = MsgBox(msg.SendUsingAccount & "不是默认邮箱地址，确定使用它发送么？", _
                     vbYesNoCancel + vbQuestion, _

zhimiaoli

Sub UnMergeFill()
 
'from http://stackoverflow.com/questions/9215022/unmerging-excel-rows-and-duplicate-data
 
Dim cell As Range, joinedCells As Range

on error resume next
For Each cell In ThisWorkbook.ActiveSheet.UsedRange
    If cell.MergeCells Then
        Set joinedCells = cell.MergeArea

zhimiaoli

Function setclip(text As String)
  Dim clip As MSForms.DataObject
  Set clip = New MSForms.DataObject
  clip.SetText text
  clip.PutInClipboard
End Function

zhimiaoli

Sub Word2PDF()
'
' 将Word文件(doc和docx)批量转换成PDF文件
' 使用的是Word的另存为功能
'


Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone