仇朝权随笔

MQCal工程算量计算表1.3.3.50（2025.12.23）发布

Sun, 28 Dec 2025 13:19:45 +0800

2025.12.23

主要更新：

1、增加星级背景颜色，取消以前模板条件格式的*背景颜色。

条件格式的星背景在多次复制粘贴后，会变得相当凌乱，导致多行计算表出现运行缓慢的问题。

2、修复1万+行计算式文件，单行计算缓慢的问题。

3、改变写序号的策略，速度更快，增加一键写序号功能，不再依赖全部快速计算或者格式计算来重写序号。

更新截图

下载地址：https://club.excelhome.net/thread-1723414-1-1.html?_dsign=c0c57158

下载地址2：http://mythqiu.ysepan.com/

vba删除文件夹

Sun, 03 Nov 2024 14:54:48 +0800

vba删除文件夹实列。Tips：删除前先删除文件夹内的文件。

Sub kk()
    On Error Resume Next
    Kill "c:\aaa\*.*"
    RmDir "c:\aaa"
End Sub

变形可以传递参数的：

Sub kk(FoldPath)
    On Error Resume Next
    Kill "" & FoldPath & "\*.*"
    RmDir FoldPath
End Sub

中国网友怼美国共和党前亚太区主席方文格指责中国网友不同情犹子

Fri, 14 Jun 2024 12:38:59 +0800

作者:葛上亭长(老韭菜头子)

中国网友怼美国共和党前亚太区主席方文格指责中国网友不同情犹太人

方文格先生你好:

看到你对网友的回复,我感到无比的震惊且愤怒。你所谓的二战期间如果全世界帮助犹太人，600万犹太人就不会被杀的言论，我要反驳的是，这不能成为你们屠杀巴勒斯坦人的理由。另外，这一言论存在错误，至少二战期间正在饱受侵略之苦的中国上海，就曾无条件的接受过五万多名犹太人，但他们的报答方式是勾结日本人，试图在中国东北地区建立犹太国家，这就是臭名昭著的"河豚计划"。庆幸的是，"河豚计划"最终失败。

比这更令人难以置信的是，就在两周前，以色列大使馆的工作人员在上海街头公然在镜头前面称，他们所在的位置是法租界。

当然，谈及犹太人和中国的渊源远不止如此。

最早在宋代，犹太人作为流浪民族进入到了中国，在这片土地上繁衍生息。宋王朝作为中国古代最富饶的王朝，他们在这里享受到了足够多的红利。但在南宋国破家亡期间，一位犹太裔商人动用私兵大量杀害南宋臣民，将尸首作为投名状送给元军。

还有鸦片战争，犹太人为了赚钱向中国倾销鸦片，中国人为此遭受到了巨大的创伤。阁下久居亚洲，对此应该不陌生吧。中国人从来没有为难过犹太人。中国现存最早的经典成熟于公元前10世纪，至今3000年。那时候你们应该刚刚被驱逐出所谓的一席之地，开启流浪生活。

如果你听懂你们的过去，你应该清楚，埃及人收留了你们，你们几次三番的背叛埃及人，最后被法老屠杀驱除的往事。古罗马收留了你们，甚至设了一个供犹太裔生活的犹太行省。但你们却趁国王图拉真东征，国家守备空虚期间发动了叛乱，击败了少数守军之后，竟然疯狂屠杀平民，甚至剥下受害者的皮肤做衣服，吃他们的肉，用他们的尸体投喂野兽。在塞浦路斯、萨拉米斯、利比亚，一共有22万平民被犹太人屠杀。在平民面前，犹太人是如此凶残，却不料图拉真回师就将犹太人打回了原形。愤怒的罗马军团从美索不达米亚沿着地中海东岸一路杀到埃及，生活在这一代的犹太人几近灭绝。后来犹太人再次发动叛乱，又把屠刀对准了基督教，大量的信仰基督教的平民被杀害。但是很不幸，他们遇到了罗马最英明的国王之一哈德良,对犹太人展开了屠杀,杀掉了12万人。他吸取了图拉真时期的教训，驱散了犹太人。至此，犹太人正式开始了流亡世界的生活。

数千年来，你们遭受过无数次屠杀，无数次驱逐，无数民族同情过你们，但你们却用无数次背叛回报他们。即便如此，你们却始终高傲的认为自己是优等民族，是高人一等的上帝选民。你们从不会在过往的教训当中反省，总结你们的文化里对其他民族带着天然的破坏、排斥和敌视。

但是，这一切在中国行不通。中国人有自己的道德观，中国人从不觉得自己是优等民族，也从不惧怕任何优越感旺盛的民族。中国人有包容心，有廉耻心，懂得自我反思，懂得知恩图报。约翰拉贝一位在南京大屠杀期间救过中国的纳税党人，每个知道他的中国人，都对他心怀感激。两年前，他的孙子履职的医院缺乏药品，向中国驻德大使馆求助，中国人民第一时间捐钱捐物。二战期间，南斯大夫救了一个女孩，50年后，她下令无差别轰炸南联盟，亲手肢解这个地方。她就是美国第一位女国务卿，犹太裔奥尔布莱特。1947年，犹太人坐船来到巴勒斯坦，难民船上写着"德国摧毁了我们的生命，你们不要摧毁我们的希望。"善良的巴勒斯坦人接纳了你们，七十多年来，你们夜以继日的屠杀着收留你们的恩人，创造了有史以来最大的露天监狱。

全世界的人民还要怎样的同情才能让你们满足?

中国古代经典有句话叫做:"国小而不处卑，力少而不畏强，无礼而侮大邻，贪愎而拙交者，可亡也。今日仅以此文相赠,请君自重。

MQCal工程算量V1.3.3.30（2024-6-10）更新增加辅助输入

Mon, 10 Jun 2024 15:36:01 +0800

MQCal工程算量辅助输入来了！

1、数据输入设置

辅助输入框可以设置辅助输入所需要的数据，并且可以设置数据对应的列。这是一个完全自定义的设置，哪一列对应什么输入数据。

2、数据上屏查找：

数据查找支持拼英首字母查找，查找的数据会根据匹配度自动排序。

数据查找后，空格直接跳转到列表，可以输入数字直接数据上屏。

3、辅助输入基本用法：

先设置数据，后在弹出的窗体输入查找字符（拼英首字母也可），然后空格（或 ↓，tab键切换到查找列表）

输入框中数据：回车直接上屏。（始终关闭窗体，无论设置中是否设置关闭）

列表选中上屏方式：回车（始终关闭窗体，无论设置中是否设置关闭）

空格（按照设置是否关闭）

鼠标左键双击（按照设置是否关闭）

鼠标右键点击（按照设置是否关闭）

候选序号上屏（按照设置是否关闭）

4、设置辅助输入对预存数据每段会自动去重复，中文逗号兼容

需要抢先体验的，评论留下邮箱体验。

vba二维数组多key稳定排序

Mon, 10 Jun 2024 15:18:51 +0800

此代码为Excel Home论坛的香川裙子所做，经测试，效果不错。szpx函数返回的是一个一维数组，下标从1开始，里面记录的是原数组的行，直接调用即可。

比如：如数据arr是100行，7列的数组，排序给brr=szpx(arr,0,1,2),数组brr是brr(1)~brr(100),里面记录的是排序后原来数组的序号。（有点绕，好好理解下）

如果无法理解上面的话，用szbr输出排序后的数组即可。因为大多数时候没有必要输出数组，直接根据szpx后的结果在arr中取该值即可。

下面是改排序在mqcal工程算量中辅助输入的应用：（查找数据后排序）

Sub test1px() '【二维数组多key稳定排序】的应用示例
    Dim ar, br, nr, sr, h&, i&, j&, m&, n&, r&, tms#
    m = 20000: n = 7
    ReDim a(1 To m, 1 To n)
    For i = 1 To m
        a(i, 1) = i
        For j = 2 To n
            r = Int(Rnd * 10): If r Then a(i, j) = r
        Next
    Next
    ar = a '以上生成m行n列的VBA内存二维数组
'    ar = [k1].CurrentRegion.Value '也可直接读取工作表区域得到二维数组
    sr = Array(3, 1, 5, 2, 7, 1) '按权重优先顺序key、Sort值交替排列的一维数组。key为列序号、Sort值：1升序、2降序
'    sr = Array(3, -1, 5, 2, 7, -1)'Sort值=-1时，升序并且空值会在最前面。(Sort=1时按工作表排序方法空值排在最后)
                                   'Sort值=2时、降序而空值自然会在最后。
    tms = Timer
    nr = szpx(ar, 0, sr) '第1参数为待排序二维数组、第2参数为不参与排序的标题行的行数
                         '第3参数为按权重优先顺序key、Sort值交替排列的一维数组。
    Debug.Print "Sort1: " & Format(Timer - tms, "0.00s ") & "Sort"
'    nr = szpx(ar, 0, 3, 1, 5, 2, 7, 1) '也可这样写入参数。从第3个参数开始交替写入key、Sort值。推荐第1种写法。
'    Exit Sub
'    下面是返回排序后数组结果?并输出到工作表的代码
    br = szbr(ar, nr, 0): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
End Sub
Function szpx(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 主要参考借鉴了Zamyi大侠的二维数组多key排序算法
    '第1参数ar：为待排序二维数组、第2参数h：为不参与排序的标题行的行数
    '第3参数sr：为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。
    Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t
    l = LBound(ar) + h: u = UBound(ar) '获取数组起始、结束位置
    ReDim x&(l To u), z(l To u + 1) As Boolean '定义存放Index序号的数组x、标记段落结束位置的数组z
    For i = l To u
        x(i) = i 'Index赋值为数组行序号、这以后排序就只需改变这个Index位置、原始数组无需改变
    Next
    z(u + 1) = True '标记最后结束位置
    If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr '判断第3参数是数组、还是多Key、Sort值序列
    j = sr2(0): If sr2(1) Mod 2 Then Call QuickSort1(ar, x, j, l, u) Else Call QuickSort2(ar, x, j, l, u)
    '按key1先进行QuickSort排序
    If sr2(1) = 1 Then Call AZE(ar, x, j, l, u) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
    For k = 2 To UBound(sr2) Step 2 '接着循环继续key2以后的排序
'        br = szbr(ar, x, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
        j2 = sr2(k): s = sr2(k + 1) '读取排序key的列序号j2 和Sort值s
        i = l: t = ar(x(i), j): i2 = i 'Do循环检查是否前key相同【注意，仅仅前key相同部分需要继续排序】
        Do
            Do
                i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
                '递增检查如果到了前前key的结束位置、或前key不同则停止退出Do循环
            Loop
            If i2 - i > 1 Then '如果间隔>1 则本key需要排序处理【注意排序区间是小范围i,i2-1】
                If s Mod 2 Then Call QuickSort1(ar, x, j2, i, i2 - 1) Else Call QuickSort2(ar, x, j2, i, i2 - 1)
                If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
            End If
            If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续从i2重新开始Do循环
        Loop
        j = j2 '更新前key列位置j
    Next
    '全部排序循环结束后、为保证最后的排序稳定性、检查最后的key值相同时必须按Index值排序。
    i = l: t = ar(x(i), j): i2 = i
    Do
        Do
            i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then Exit Do '检查方法相同
        Loop
        If i2 - i > 1 Then Call QuickSort(x, i, i2 - 1) '如果间隔>1 则Index值需要排序处理
        If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续
    Loop
    szpx = x '多key稳定排序处理结束、返回排序结果的Index数组x
'    szpx = szbr(ar, x, h) '或返回按排序后Index顺序引用返回的排序结果数组br
End Function
Function QuickSort(x, l&, u&) 'A-Z QuickSort '最后稳定排序时对相同key的Index值升序排序
    Dim i&, j&, n&, r&
    i = l: j = u: r = x((l + u) \ 2)
    While i < j
        While x(i) < r: i = i + 1: Wend 'A-Z
        While x(j) > r: j = j - 1: Wend 'A-Z
        If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort(x, l, j)
    If i < u Then Call QuickSort(x, i, u)
End Function
Function QuickSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort 按原数组j2列对应内容进行升序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) < r And i < u: i = i + 1: Wend   'A-Z
        While ar(x(j), j2) > r And j > l: j = j - 1: Wend   'A-Z
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort1(ar, x, j2, l, j)
    If i < u Then Call QuickSort1(ar, x, j2, i, u)
End Function
Function QuickSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort 按原数组j2列对应内容进行降序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A
        While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort2(ar, x, j2, l, j)
    If i < u Then Call QuickSort2(ar, x, j2, i, u)
End Function
Function AZE(ar, x, j, l&, u&) 'Sort值=1时、把排序完成后的空值移动到最后
    Dim i&, i2&, y
    For i = l To u
        If ar(x(i), j) <> "" Then '检查直到非空位置时停止
            y = x '复制Index数组x到y
            For i2 = l To i - 1
                x(u - i + i2 + 1) = y(i2) '前面的空值对应Index值移动到最后
            Next
            For i2 = i To u
                x(i2 - i + l) = y(i2) '后面的非空值对应Index值移动到前面
            Next
            Exit For
        End If
    Next
End Function
Function szbr(ar, nr, h&) 'Output Result Array 按排序后nr数组顺序、引用原数组对应Index值各列返回数组排序结果
    Dim br, i&, i2&, j2&, l&, l2&, u&, u2&
    l = LBound(ar) + h: u = UBound(ar)
    l2 = LBound(ar, 2): u2 = UBound(ar, 2)
    br = ar
    For i = l To u
        i2 = nr(i) '引用原数组对应Index值
        For j2 = l2 To u2
            br(i, j2) = ar(i2, j2) '按排序结果引用原数组对应值返回
        Next
    Next
    szbr = br
End Function

vba删除多级目录及其目录下文件的自定义函数

Mon, 10 Jun 2024 15:15:40 +0800

删除多级目录：如 call rmdirs("D:\test") 将删除此test目录下所有目录和文件。

Function RMDirs(Str As String) As Boolean
Rem RMdir的升级版本，根据目录地址删除最后文件夹及里面的文件
Rem 使用方法Call RMDirs("D:\test\test2\test3")
Rem if RMDirs("D:\test\test2\test3")=True then doSomething  else doOtherSomething
    Err.Clear
    On Error GoTo ele
    Dim fs, f
    If Len(Str) = 0 Then Exit Function
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Str)
    f.Delete
    RMDirs = True   '删除多级目录成功
    Set fs = Nothing
    Set f = Nothing
    Exit Function
ele:
    RMDirs = False  '删除多级目录失败
    Set fs = Nothing
    Set f = Nothing
    'MsgBox Err.number & Err.Description
End Function

VBA自动创建多级目录

Mon, 20 May 2024 18:30:12 +0800

VBA本身的mkdir是不能直接创建多级目录的，必须一级一级的创建目录。

比如：D:\test\test1如果test目录不存在，直接 mkdir "D:\test\test2" 将会出错。

下面是一个循环判断自动创建多级目录的代码：

Function MKDirs(Str As String) As Boolean
Rem mkdir的升级版本，根据目录地址创建文件夹
Rem 使用方法Call MKDirs("D:\test\test2\test3\")
Rem if MKDirs("D:\test\test2\test3\")=True then doSomething  else doOtherSomething
    On Error Resume Next
    Dim arr, i%, newStr$
    If Len(Str) = 0 Then Exit Function
    If InStr(1, Str, "\") > 0 Then
        arr = Split(Str, "\")
        For i = 0 To UBound(arr)
            If Len(arr(i)) > 0 Then
                    newStr = newStr & arr(i) & "\"
                If Dir(newStr, vbDirectory) = "" Then
                    MkDir newStr
                    If Err.number <> 0 Then GoTo ele
                End If
            End If
        Next i
    Else
        If Dir(Str, vbDirectory) = "" Then
            MkDir Str
            If Err.number <> 0 Then GoTo ele
        End If
    End If
    MKDirs = True   '创建多级目录成功
    Exit Function
ele:
    MKDirs = False  '创建多级目录失败
    'MsgBox Err.number & Err.Description
End Function

MCal工程通用计算式算量表V1.3.2.20 2024.5.20

Mon, 20 May 2024 10:57:25 +0800

MCal工程通用计算式算量表V1.3.2.20
2024.5.20
1、修复在只有一行数据情况下，次级计算无法批量计算
2、修复更新页脚在有页脚的情况下无法更新
3、增加汇总计算会记住最后一次星级计算
4、更改汇总的快捷方式Ctrl+`,这样和Ctrl+1等对应起来
5、取消在结果列点击出结果的计算方式

MCal工程通用计算式算量表V1.3.2.10 2024.5.14

Tue, 14 May 2024 17:54:23 +0800

MCal工程通用计算式算量表V1.3.2.10

2024.5.14

1、更新下tab菜单,菜单收缩后的效果如下：

全菜单：

2、新增加次级计算数量为20个

3、增加结果处理

西方伪史：汤若望历法作假来龙去脉

Sun, 14 Apr 2024 17:44:05 +0800

作者：东哥说文史

很久没有分享西方伪史的故事了，可是看了这段视频，忍不住要做一期超长的节目，质疑一下从历年不是我们中国人发明的。

下面引用网络某博主的厥词：
农历年，是德国人倘若望花了15年时间，从海南岛到鹤岗，他每一年按到200多公里的速度北上算这个阳光直射地方的这个时间，所以你看到没有，哪有阳历年哪有24个节气跟这个阳历靠着这么近的呢，最多相差一两天。你看看清明节，你以为是我们祖宗留下的东西？我们祖宗留那么多下来，这么准确的东西，我就服了。我们这祖宗嘛，都是扯淡的。

网络名人推崇的汤若望是明朝来到中国的外国人。崇祯二年，徐光启受命重修历法。徐光启邀请德国人汤若望修订立法，搞出来的叫《崇祯历书》。

水平怎么样呢？代表中国传统历法的中国天文学家和代表新历法的汤若望小组做了一次天文学预测竞赛。预测，日食，月食，水星和木星的运动，一共比赛了8次，哪家预测的准，就用哪家的立法。

那么谁赢了呢？按照明史里面的记载，8次比赛外国人汤若望都赢了，8:0大胜中国队。

这里面隐藏着一个天大的秘密。明朝历史是清朝人写的，依据是什么呢？依据是汤若望版本的说法，原来《崇祯历书》做好之后还没有颁布，崇祯皇帝就上吊死了。明朝灭亡了，满清入关，不信任汉人，就让汤若望这一批外国人掌管国家天文历法。汤若望就把137卷的《崇祯历书》删改为103卷，明目张胆地改名字叫“西洋新法历书”，颁布施行。

在《崇祯历书》面还有两篇重要文献，一个叫《古今交食考》，一个叫《治历缘起》，一个记载了日食月食的记录，一个介绍了这一次修改立法的经过，尤其是这一篇《治历缘起》，原文件12卷对被汤若望删减成8卷，德国人汤若望到底删掉了什么呢？以前一直没有人知道，直到十几年前，中科院自然科学史研究所李亮，中国科技大学吕林峰和石云里三位学者联合发表了一篇重磅论文《被遗漏的交食，传教士对崇祯改历时期，交食记录的选择性删除》。原来今天一般人看到的崇祯历书，是被汤若望动过手脚的。原始版本的《崇祯历书》在韩国有一套奎章阁收藏的明朝刻本。

中国学者对照明清两个版本的《崇祯历书》，发现汤若望竟然把天王预测竞赛和观测记录当中自己推算错误的记录，删除的一干二净，留下的全部是自己预测准确的记录，这样当然就是常胜将军了。

中国传统立法就这样被泼了400年脏水，直到今天，还有人拿这件事情颠倒黑白，嘲笑中国古代的天文历法。

这篇揭露德国人汤若望天文学造假的论文在两个公开场合做个报告，一个是2011年7月在安徽合肥召开的第十三届国际东亚科学技术与医学史会议；一次是2013年7月，在英国曼彻斯特召开的第24届国际科学史大会。

欧洲人不但会给自己的古代历史造假，来到中国之后一样不老实啊。我有8天没有质疑西方伪史了，因为自从我提到文化霸权主义和新殖民主义之后，后台不友好的留言多了起来，流量也受到了影响，好像是刺痛了某些人的神经。本来我想敬而远之，停止更新西史辩伪系列。现在想一想，不能一代一代被他们给骗下去，从我的视频的遭遇就能够折射出西史辩伪研究的困难性，所以呢我要大张旗鼓的推荐这一批学者的著作，他们是《光从中华来，言不必称希腊》、《虚构的西方文明史》，

《虚构的古希腊文明》，《欧洲文明史察疑》。再早一点的还有何新老师的《希腊伪史考》和《希腊伪史续考》给大家展示一下，可惜了，这两个版本现在已经是绝版了，这几本书在我的视频下方和我的橱窗里都有，大家可以购买这些学者的著作，支持他们继续研究。大家一起把颠倒的历史颠倒过来，感谢支持，

不见不散，朋友们。

作者发表的抖音视频：

5.35 复制打开抖音，看看【东哥说文史的作品】中国古代天文历法是怎样被抹黑的？# 历史 # 好书... https://v.douyin.com/iYHshP3d/ B@T.lP 12/12 Btr:/