吕雄

Sub Collectwk()

    'ExcelHome VBA编程学习与实践

    Dim Trow&, k&, arr, brr, i&, j&, book&, a&

    Dim p$, f$, Rng As Range

    With Application.FileDialog(msoFileDialogFolderPicker)

    '取得用户选择的文件夹路径

        .AllowMultiSelect = False

        If .Show Then p = .SelectedItems(1) Else Exit Sub

    End With

    If Right(p, 1) <> "\" Then p = p & "\"

    '

    Trow = Val(InputBox("请输入标题的行数", "提醒"))

    If Trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub

    Application.ScreenUpdating = False '关闭屏幕更新

    Cells.ClearContents '清空当前表数据

    Cells.NumberFormat = "@" '设置单元格格式为文本

    ReDim brr(1 To 200000, 1 To 1)

    '定义装汇总结果的数组brr，最大行数为20万行

    f = Dir(p & "*.xls*")

    '开始遍历指定文件夹路径下的每个工作簿

    Do While f <> ""

        If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错

            With GetObject(p & f)

            '以\'只读\'形式读取文件时，使用getobject方法会比workbooks.open稍快

                Set Rng = .Sheets(1).UsedRange

                If IsEmpty(Rng) = False Then '如果工作表非空

                    book = book + 1 '标记一下是否首个Sheet,如果首个sheet，BOOK=1

                    a = IIf(book = 1, 1, Trow + 1) '遍历读取arr数组时是否扣掉标题行

                    arr = Rng.Value '数据区域读入数组arr

                    If UBound(arr, 2) > UBound(brr, 2) Then

                    '动态调整结果数组brr的最大列数，避免明细表列数不一的情况。

                        ReDim Preserve brr(1 To 200000, 1 To UBound(arr, 2))

                    End If

                    For i = a To UBound(arr) '遍历行

                        k = k + 1 '累加记录条数

                        For j = 1 To UBound(brr, 2) '遍历列

                            brr(k, j) = arr(i, j)

                        Next

                    Next

                End If

                .Close False '关闭工作簿，不保存。

            End With

        End If

        f = Dir '下一个工作簿

    Loop

    If k > 0 Then

        [a1].Resize(k, UBound(brr, 2)) = brr

        MsgBox "汇总完成。"

    End If

    Application.ScreenUpdating = True '恢复屏幕更新

End Sub

May

VBA设置OUTLOOK批量提取多个邮件下的附件

设置Outlook收件箱（Inbox）下建立子文件夹attachment；

计算机磁盘选定路径建立目标文件夹attachment download；

输入代码块中的代码（文件夹名和路径名）

Sub Savetheattachment()
         Dim olApp As New Outlook.Application
         Dim nmsName As Outlook.NameSpace
         Dim vItem As Object
         Set nmsName = olApp.GetNamespace("MAPI")
         Set myfolder = nmsName.GetDefaultFolder(olFolderInbox)
         Set fldFolder = myfolder.Folders("attachment")
         For Each vItem In fldFolder.Items
             For Each att In vItem.Attachments
                 att.SaveAsFile "D:\attachment download\" & att.FileName
             Next
         Next
            Set fldFolder = Nothing
            Set nmsName = Nothing
End Sub

May 31 , 2020 阅读全文

---

April

终将是，半生烟雨两茫茫

近日，阴雨连绵，凡身多感，

无奈终日繁繁，只缘上阙，不见后言。

待身归红楼樵林日，再续半生烟雨未了篇！

April 26 , 2020 樵林后子  阅读全文

---

March

观点争鸣

个人论文-观点争鸣：

8.【中国电子银行网】我国电子银行发展范式初探—兼论优势银行的共性特征及现实差异

7.违纪测量：违纪查处量与执纪力度、违纪存量的现实关系——解读违反中央八项规定精神问题的数据特征

6.【共产党员网】用青春之我创造青春之中国、青春之民族—学习习近平总书记在纪念五四运动100周年大会上的重要讲话精神

5.【广州大学学报（社会科学版）】二十年（1998-2017）来中国廉政理论研究现状与展望——基于4239篇CSSCI期刊论文的文献分析

4.【廉政与治理】当前中国廉政理论研究现状——基于高校廉政研究机构的Citespace知识图谱分析

3.【ISTP】The Mapping Mechanism of Modernization of National Governance and Corruption Governance

2.【第十一届中国廉政研究论坛论文】十八大以来全面从严治党的伟大实践：基于违反中央“八项规定”精神问题数的分析

1.中国反腐倡廉建设路径透视

---

March 26 , 2020 随笔札记  阅读全文

---

VBA设置excel单元格下拉菜单多选

Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 2 And Target.Row = 10 Then '此处选定第2列第10行(B10)的单元格为需要设置下拉多选的单元格
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        If InStr(1, oldVal, newVal) <> 0 Then  '重复选择视同删除
          If InStr(1, oldVal, newVal) + Len(newVal) - 1 = Len(oldVal) Then '最后一个选项重复
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
          Else
            Target.Value = Replace(oldVal, newVal & ",", "") '不是最后一个选项重复的时候处理逗号
          End If
        Else '不是重复选项就视同增加选项
        Target.Value = oldVal & "," & newVal
'      NOTE: you can use a line break,
'      instead of a comma
'      Target.Value = oldVal _
'        & Chr(10) & newVal
        End If
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub

March 23 , 2020 阅读全文

---

四分钟的通话

“妈，明天…明天过年…我就不回来了”电话那头姐姐有些迟疑地说。

今天是农历腊月二十九，也是姐姐成为一名医务人员的第5个年头了。和往年一样，姐姐通常是会打来电话提前知会母亲明天几点到家的。

母亲看到来电显示，面露喜色地对我说，想必是你姐明天要回来了。电话刚接通，母亲脸色暗了许多，显然有些沮丧，通常母亲是会问些缘由的，此时却沉默了下来。

通话安静了片刻，姐姐连忙解释道“明天医院临时有事，需要人员值岗，所以…所以明天就不回家了”。

母亲沉默片刻，低声回应：“嗯……好…”。这次姐姐并没有像往常一样与母亲东聊聊西问问、玩笑半晌，只是简单寒暄几句便打算挂断电话，母亲也只是连连叮嘱“注意安全哈、注意安全…”。母亲此刻对姐姐喋喋唠叨的样子却还是同十多年前一般，只是此次似乎略多了些担忧与不安！不足四分钟的通话，与往常相比异显沉重。或许，每一秒都牵拨着母亲与姐姐欲言又止的复杂心绪吧！

“自从衣白褂，我儿是人儿”。 穿上白衣大褂那天起，女儿就不再是母亲一人的女儿了。疫情当前，为医为女自该有女儿的责任与担当。“爱国甚爱家、医患甚医亲”自该是女儿为医为女的操守与初心，母亲深晓此理，对姐姐自然常感欣慰与荣光。或许，母亲对子女一生最真切、最朴实的爱便是交融了担忧与不安、欣慰与荣光吧！

“自从衣白褂，大家即小家”。医务工作5年，“急人所急，忧人所忧”的从业信条不知何时已潜移默化地融入姐姐寻常又再寻常不过的工作与生活之中。但凡国家需要、社会需要、患者需要，自己的方寸小家就愈显热闹，热闹中有病患痊愈时的喜悦、也有连声道谢时的欣慰；有同事互勉时的感动、也有医患互助时的感激；有学可出战时的自信、也有为国报效时的自豪。大家融成小家，小家住着大家，或许，这便是包括姐姐在内的所有医务工作者最具力量、最具温情的“及人之爱”吧！

纵是星火微光，越要纵身炉火，予人光明、予人希望！这，便是你我心目中的盖世英雄——医务工作者！

“今日”，我定要出征；“明天”，我必将凯还！致敬所有奋战在疫情一线的医务工作者：

今日衣白褂，只为护国安。

待明日，平疫患。

旌旗傲立凯歌还！

March 18 , 2020 随笔札记  阅读全文

---

Python计算年终奖个人所得税缴纳方案并绘制3D散点图.md





年终奖个人所得税计算方案：

方案一：年终奖单独计算，不分摊并入每月工资计算纳税

方案二：年终奖分摊并入每月工资计算纳税

![中华人民共和国个人所得税法实施条例](http://www.gov.cn/zhengce/content/2018-12/22/content_5351177.htm)

![中华人民共和国个人所得税法](http://www.chinatax.gov.cn/n810219/n810744/n3752930/n3752974/c3970366/content.html)

March 18 , 2020 阅读全文

---