Excel 2003另存为新工作簿时，去除模块里的宏，其实只需这一句。

老谭酸菜

shenghua8 发表于 2013-11-23 18:37
谢谢谭Sir ！
空值也试过了，没问题。
我还奢求它应用于整列。

难道这个不能应用于整列？
=众值(D1:D65536)，这样总可以吧？

不过我的老师群子已经写了更快速的代码，不妨就用她的咯。
{:soso_e100:}

老谭酸菜

楼主的意思是要忽略空白单元格。群子的和俺的代码都没考虑这个问题。呵呵。需要加一个判断更合楼主的心意。

香川群子

老谭酸菜 发表于 2013-11-23 21:01
楼主的意思是要忽略空白单元格。群子的和俺的代码都没考虑这个问题。呵呵。需要加一个判断更合楼主的心意。

那就这样：

1. Function 众值(rng As Range)
   
2.     Set d = CreateObject("Scripting.Dictionary") '定义字典
   
3.     Set rng = Intersect(rng, ActiveSheet.UsedRange) '确保可以直接引用整列
   
4.     For Each c In rng
   
5.         t = c.Text '使用变量t写入单元格值，提高效率
   
6.         If Len(t) Then '排除空白单元格
   
7.             n = d(t) + 1: d(t) = n '不需要d.Exists判断，是多余的。
   
8.             If n > m Then m = n: s = t '后面使用变量进行计算，非常地简单、高效
   
9.         End If
   
10.     Next
    
11.     众值 = s
    
12. End Function

复制代码

可以直接引用整列如：=众值(A:D)

老谭酸菜

香川群子 发表于 2013-11-23 21:17
那就这样：可以直接引用整列如：=众值(A:D)

{:soso_e113:}{:soso_e179:}
这样就完成楼主的心愿了。
range仅受工作表单元格数量的限制。即使这样“=众值(A:IV)”也没问题。

shenghua8

香川群子 发表于 2013-11-23 21:17
那就这样：可以直接引用整列如：=众值(A:D)

就是这样！
我用50多列不同格式和类型的值测试，都能得出正确结果：
1、有唯一众值的，得到这个众值。
2、有两个及以上众值的，得到首先遇到的众值。
3、没有众值的，得到第一个值，这个还能起到另外的作用，检查是否都是唯一值。
4、整列都是空白的，得到#VALUE!

另外，整行也试了，也没问题。

{:soso_e183:}
漂亮、知性、善良的老师，高端大气上档次，低调奢华有内涵。

shenghua8

老谭酸菜 发表于 2013-11-23 21:34
这样就完成楼主的心愿了。
range仅受工作表单元格数量的限制。即使这样“= ...

完成了，完成心愿了！{:soso_e179:}

谭Sir，您创造性的用了“众值”这个词，真是准确啊。

jjmsxr

山菊花 发表于 2013-11-22 20:28
试试：
Sub 另存为XML表格()
    Dim cPath$, cFile$

漂亮！老师，可不可以导出指定的一个工作表？？？

山菊花

jjmsxr 发表于 2023-3-24 23:06
漂亮！老师，可不可以导出指定的一个工作表？？？

将指定的工作表复制为新工作簿，再保存为指定格式。

jjmsxr

山菊花 发表于 2023-3-26 16:11
将指定的工作表复制为新工作簿，再保存为指定格式。

Sub 另存为XML表格()
    Dim cPath$, cFile$
    Application.DisplayAlerts = False
    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '将文件保存到桌面
    cFile = cPath & Format(Now, "yyyymmddhhmmss_") & ThisWorkbook.Name  '文件名（伪装的扩展名）
    ThisWorkbook.SaveAs Filename:=cFile, FileFormat:=xlXMLSpreadsheet '另存为
    ThisWorkbook.Close False '退出
    Application.DisplayAlerts = True
End Sub

老师，怎么修改？？？

山菊花

Sub 另存为XML表格()
    Dim cPath$, cFile$, cSh$
    Application.DisplayAlerts = False
    cPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '将文件保存到桌面
    cSh = "Sheet2" '工作表名
    cFile = cPath & Format(Now, "yyyymmddhhmmss_") & cSh  '文件名
    ThisWorkbook.Sheets(cSh).Copy '复制工作表到新工作簿
    With ActiveWorkbook
        .SaveAs Filename:=cFile, FileFormat:=xlXMLSpreadsheet '另存为
        .Close False '退出
    End With
    MsgBox "工作表已另存。"
    Application.DisplayAlerts = True
End Sub