Excel中将15位身份证号转换为18位

Excel中将15位身份证号转换为18位

 　　假设A列自A2起是身份证号(15位或18位)。

　　1、身份证号全部改为18位，输入数组公式：=IF(LEN(A2)=15,REPLACE(A2,7,,19)&MID("10X98765432",MOD(SUM(MID(REPLACE(A2,7,,19)

,ROW(INDIRECT("1:17")),1)*2^(18-ROW(INDIRECT("1:17")))),11)+1,1),A2)

　　注意：数组公式输入方法：输入公式后不要按回车，而是按Ctrl+Shift+Enter。

　　2、身份证号全部改为15位，输入公式：=IF(LEN(A2)=15,A2,LEFT(REPLACE(A2,7,2,),15))

　　3、计算出生日期：=IF(A2"",TEXT((LEN(A2)=15)*19&MID(A2,7,6+(LEN(A2)=18)*2),"#-00-00")+0,)

　　4、判断性别：=IF(A2"",IF(MOD(RIGHT(LEFT(A2,17)),2),"男","女"),)

　　最终结果如图：

Excel:重复名次也可以查姓名成绩

 　　当老师的，对分析学生成绩大概有瘾。这不，本来我们已经把学生各学科的成绩、总分、名次都排出来了，并按照总分进行了升序排序，但现在又有任课老师过来要求希望能够把自己学科的前10名的学生姓名及成绩找出来。按理说，这个要求并不是很困难，但是麻烦就在于学生各科名次有可能相同，这样的话，前10名的学生其实不一定是10个人，有可能更多。每个学科都要这么做的话，工作量也不小，所以，还是得靠函数和公式来帮忙。

　　图1 原始成绩表

　　原始的成绩表如图1所示。姓名位于C2:C92单元格，语文成绩位于D2:D92单元格区域。我们就以查找语文学科的前10名成绩及学生姓名为例。为方便比较结果，图1中我们已经将数据按语文成绩降序进行了排序，实际操作中是不需要事先排序的。

　　一、名次表的建立

　　前面我们说过，我们不太容易确定排在前10名的学生共有多少，所以，我们需要使用公式将它们找出来。当然，最好顺便将名次表填写出来。完成结果如图2所示。

　　图2 成绩排序

　　将鼠标定位于X3单元格，然后在编辑栏输入公式=TEXT(SUMPRODUCT(($D$2:$D$92=LARGE($D$2:$D$92,ROW(1:1)))/COUNTIF($D$2:$D$92,$D$2:$D$92)),"第G/通用格式名")，回车后就可以得到第1名的结果。选定X3单元格，向下拖动其填充句柄至出现第11名为止。

　　这里用到了几个函数，感觉上比较复杂。其实思路是这样的：ROW(1:1)的结果是1，而LARGE($D$2:$D$92,1)的结果是在指定的单元格区域中最大的一个数;那么公式中($D$2:$D$92=LARGE($D$2:$D$92,ROW(1:1)))可以理解为拿D2:D92单元格区域中的数据与该区域中最大值比较，大于或等于该值及小于该值的则会分别以TRUE、FALSE的结果保存在一个数组中。

　　公式中COUNTIF($D$2:$D$92,$D$2:$D$92))部分则会统计D2:D92单元格区域中每一个数值出现的次数，也分别保存到一个数组中。所以，我们所用公式中SUMPRODUCT(($D$2:$D$92=LARGE($D$2:$D$92,ROW(1:1)))/COUNTIF($D$2:$D$92,$D$2:$D$92))在执行时会得到一个类似于SUMPRODUCT({TRUE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;FALSE;}/{1;1;2;2;1;2;2;1;2;2;2;2;1;})的结果。两个数组中的对应的数据分别相除，再将所有的商相加，正是分数所对应的名次。这种方法即使名次是并列的，也不会影响显示效果。

　　至于最外层的TEXT函数，则是将得到的结果转换为按指定数字格式表示的文本。也就是本来内层公式运算的结果是数字1，现在我们将它显示为第1名。

　　二、分数的查找

　　将鼠标定位于Y3单元格，在编辑栏中输入如下公式=INDEX($D$2:$D$92,MATCH(LARGE($D$2:$D$92+1/ROW($D$2:$D$92),ROW(1:1)),$

D$2:$D$92+1/ROW($D$2:$D$92),0))，然后按下Ctrl+Sh

　　ift+Enter快捷键，完成数组公式的输入。这一步很关键的，否则不会出现正确的结果。

　　向下拖动Y3单元格的填充句柄向下至最后一个单元格完成公式的复制。

　　我们还是简单解释一下公式的思路。

　　由于D2:D92区域中有很多数据是重复的，这给我们造成了困难。所以，我们要想办法使每一数据都变成唯一。公式中$D$2:$D$92+1/ROW($D$2:$D$92)就是给D2:D92区域中每一个数据都加了该数据对应行数的倒数。由于每一数据对应的行数是不一样的，这样，就会使每一数据都变成了唯一的值，并保存到了一个数组中。

　　公式中的LARGE($D$2:$D$92+1/ROW($D$2:$D$92),ROW(1:1))还是返回了上面所得数组中的最大值。本例中的结果是{96.5｝。

　　公式中MATCH(LARGE($D$2:$D$92+1/ROW($D$2:$D$92),ROW(1:1)),$D$2:$D$92+1/ROW($D$2:$D$92),0)返回的是刚刚得到的最大值在数组中的位置。本例中的结果是{1｝。

　　这样，其实Excel最后执行的查询就是INDEX($D$2:$D$92,1)了，自然可以返回在$D$2:$D$92区域中的第一个值了。

　　三、姓名的查找

　　将鼠标定位于Z3单元格，在编辑栏中输入公式=INDEX($C$2:$C$92,MATCH(LARGE($D$2:$D$92+1/ROW($D$2:$D$92),ROW(1:1)),

$D$2:$D$92+1/ROW($D$2:$D$92),0))，同样按下Ctrl+Shift+Enter快捷键完成数组公式的输入。

　　向下拖动Z3单元格的填充句柄向下至最后一个单元格完成公式的复制。最后的效果如图3所示。

　　图3 完成公式的复制(点击看大图)

　　其实您肯定已经明白了，姓名的查找与前面分数的查找是一样的。公式本身也没有什么大的变化。所以，明白了前面的方法，要查找别的什么东西也就方便了。

　　其它的学科可以照此办理。只要注意变换一下公式中的单元格区域就可以了，我这里就不罗嗦了。

用Excel列表实现批量录入功能

 　　我们在使用Excel的过程中，通常需要输入大量的数据。这是保证我们顺利完成各项工作的基础。但是，在录入数据的过程中，尤其是录入大量数据的时候，经常会出现一些不经意的录入错误，而这，会严重影响我们所得到的结果正确性。那么，怎样才能有效地控制这种录入错误的发生呢?除了细心、细心、再细心以外，在Excel中完成必要的设置，以最大可能地减少错误的发生也是极为重要的。

　　一、设置数据列表

　　有时我们需要录入的数据是某些重复数据中的一个，比如单位员工所属的部门。单位中部门个数是有限的，如果我们都通过键盘手工录入每位员工的工作部门，那自然是费时费力，还容易出错的。因此，我们不如为这些部门指定一个数据列表。录入时只需要在下拉列表中单击选择相应的部门，就可以了。这不仅可以提高录入速度，还会使得录入的质量得到保证。

　　首先选中要填写员工部门的所有单元格，点击功能区数据选项卡数据工具功能组中的数据有效性按钮，在弹出的菜单中点击数据有效性命令，打开数据有效性对话框。

　　点击对话框中设置选项卡，在允许下方的下拉列表中选择序列选项，然后在下面来源输入框中输入各部门名称(人事部,一车间,二车间,生产部,技术部,办公室)，部门之间用英文的逗号隔开，如图1所示。点击确定按钮关闭对话框。

　　图1 Excel设置序列

　　我们也可以在工作表的空白单元格某列中分别输入各个部门名称，比如在H1:H6单元格区域。然后在来源下的输入框中输入=$H$1:$H$6，也可以得到同样的效果。

　　现在将鼠标定位于刚才选中的那些单元格区域任一单元格，就会在右边出现一个下拉箭头，点击它就会出现刚才我们所设置的下拉列表，如图2所示，单击其中的项目就可以完成输入了。

　　图2 Excel中的下拉列表

　　二、在其它工作表中使用

　　如果我们希望能在其它的工作表单元格区域中使用这个部门下拉列表，那么我们可以使用自定义名称完成这个任务。

　　在空白单元格列中录入相应部门名称，比如H1:H6单元格区域。然后选中此单元格区域，点击功能区公式选项卡定义的名称功能组中的定义名称按钮，打开新建名称对话框。如图3所示，在名称右侧的输入框中输入名称，比如bumen。在范围下拉列表中选择工作簿，而在引用位置右侧的输入框中会自动使用我们选中的单元格区域。确定后，就可以为我们所选的单元格区域指定bumen的名称了。

　　图3 Excel新建工作簿

　　现在要做的，就是在选定工作表的相应单元格区域后，再打开数据有效性对话框，然后在来源输入框中输入=bumen，就可以在当前的工作表中使用这个部门列表了。

　　如果觉得这个自定义名称的方法有些罗嗦的话，那下面的方法就简单多了。

　　选中已经设置好数据有效性的单元格，然后按下Ctrl+C键进行复制。再将鼠标定位于目标单

　　元格，点击功能区开始选项卡剪贴板功能组中的粘贴按钮下的小三角形，在弹出的菜单中点击选择性粘贴，打开选择性粘贴对话框。选中有效性验证单选项就可以了，如图4所示。

　　图4 Excel选择性粘贴

Excel实用操作技巧：快速录入性别

 　　在用Excel 统计一些涉及到人事方面的信息时，经常需要输入每个人的性别。如果按部就班地分别输入，数据如果比较多，那么无论是采用五笔输入还是拼音输入，这个男、女的输入都会显得比较麻烦。有没有办法使我们稍微地偷点儿懒，让这个性别的录入问题不那么枯燥呢?下面的这几个小小的招数，也许可以让你摆脱烦恼，不如试试?

　　一、自定义格式

　　选中要输入性别的单元格区域，点击右键，在弹出的菜单中点击设置单元格格式命令，打开设置单元格格式对话框。点击对话框的数字选项卡，在左侧的分类列表中选中自定义，然后在右侧的类型输入框中输入[=1]"男";[=2]"女"，如图1所示。确定后，只要在这些单元格中输入数字1，则会显示为男，输入数字2，则显示为女。这样比较起来，输入一个数字比起输入汉字，那当然要简单得多了。

　　图1(点击看大图)

　　这种方法，在屏幕上显示的是男、女，不过，在编辑栏中可以看到，仍然是1、2。

　　二、查找替换

　　使用查找替换的方法也可以实现上面的这种效果。在输入时，男就输入1，而女则输入2。全部输入完成后，选中这些单元格区域，然后按下Ctrl+F快捷键，打开查找和替换对话框。点击替换选项卡，在查找内容输入框中输入1，在替换为输入框中输入男，如图2所示，然后点击全部替换按钮，就可以将选中区域中的全部数字1替换为男了。用同样的方法，将2替换为女，大功告成。

　　图2(点击看大图)

　　这种方法输入时只需要输入数字，方便快捷。替换后则可以换成相应的文本，屏幕显示与实际内容也一致，比起第一种方法可以避免某些因屏幕显示与实际内容不一致造成的麻烦。

　　三、公式设置

　　这种方法需要加上辅助列。比如性别输入应该在D2:D100单元格区域，而我们使用C列作为辅助列。输入时，在C列完成相应的输入过程。仍然是男为1、女为2。也可以只在应为男时输入1，则为女时不必输入。全部完成后，在D2单元格中输入公式=IF(C2=1,"男","女")，然后拖动D2单元格的填充句柄至D100单元格。松开鼠标就可以得到所需要的内容了，如图3所示。我们可以选中C列单元格区域，点击右键，然后在弹出菜单中点击隐藏命令，将C列隐藏起来。

　　图3

　　这种方法看起来虽然麻烦一些，但是在输入时我们可以只输入一种数字，那积少成多，从整个过程来看的话，也是能省下不少时间和功夫的。

　　好了，就这三种方法吧。您看中哪一种了?

Excel用SUMPRODUCT实现有条件排名

 　　前些日子市里搞了一次模拟考试，下发了汇总后的成绩表。全市三所学校各个专业的学生成绩都放到了一个工作表中，格式如图1所示。为了做好成绩分析，主任要求做好两个排名：一是排出每位学生在全市相同专业的学生中的名次;二是排出每位学生在本校本专业中的名次;两个排名都以总分为依据。

　　图1(点击看大图)

　　这个工作以前也做过，每次都得将数据按专业、按学校分别筛选出来复制到不同的工作表中，然后在不同的工作表中用RANK函数进行排序。全市三所学校一千多个学生，每所学校都有七到八个专业，所以这个筛选复制工作也是费时费力，筛选复制完成后还要在十多个工作表中进行排名工作，非常麻烦。不过这一次，工作完成得却异常顺利，只需要十分钟就可以完成全部的工作了。因为，这次我们使用了SUMPRODUCT函数来完成这个有条件的排名工作。具体实现过程如下：

　　一、准备工作

　　选定总分所在的H2:H1032单元格区域，点击功能区公式选项卡定义的名称功能组中定义名称按钮，在弹出的新建名称对话框名称输入框中输入为此区域定义的名称zongfen。此时，对话框下方的引用位置后的输入框中已经自动输入我们选定的单元格区域=对口!$H$2:$H$1032，如图2所示。

　　图2

　　按同样的方法，选定学校所在单元格区域I2:I1032、专业所在单元格区域J2:J1032，分别为它们指定名称xuexiao和zhuanye。

　　完成后，这准备工作就算是结束了。

　　二、排定名次

　　在K1单元格输入标题按专业排名。点击K2单元格，输入公式=SUMPRODUCT((zhuanye=$J2)*($H2

　　在L1单元格输入标题校内专业排名。点击L2单元格，输入公式=SUMPRODUCT((zhuanye=$J2)*($H2

　　图3(点击看大图)

　　如果您也遇到类似的问题，比如平行班的成绩汇总在一张工作表中，而我们又需要学生的班内名次，那么不妨照此办理一回，呵呵，那效果，真的是谁用谁知道啊。a

ASP操作Excel的方法

 代码如下：

%
'*******************************************************************
'使用说明
'Dim a
'Set a=new CreateExcel
'a.SavePath="x" '保存路径
'a.SheetName="工作簿名称"       '多个工作表 a.SheetName=array("工作簿名称一","工作簿名称二")
'a.SheetTitle="表名称"         '可以为空  多个工作表 a.SheetName=array("表名称一","表名称二")
'a.Data =d '二维数组             '多个工作表 array(b,c) b与c为二维数组
'Dim rs
'Set rs=server.CreateObject("Adodb.RecordSet")
'rs.open "Select id, classid, className from [class] ",conn, 1, 1
'a.AddDBData rs, "字段名一，字段名二", "工作簿名称", "表名称",     true    'true自动获取表字段名
'a.AddData c, true , "工作簿名称", "表名称"    'c二维数组          true  第一行是否为标题行
'a.AddtData e, "Sheet1"   '按模板生成  c=array(array("AA1", "内容"), array("AA2", "内容2"))
'a.Create()
'a.UsedTime        生成时间，毫秒数
'a.SavePath        保存路径
'Set a=nothing
'设置COM组件的操作权限。在命令行键入DCOMCNFG，则进入COM组件配置界面，选择MicrosoftExcel后点击属性按钮，将三个单选项一律选择自定义，编辑中将Everyone加入所有权限
'*******************************************************************
Class CreateExcel 
    Private CreateType_
    Private savePath_
    Private readPath_
    Private AuthorStr              Rem 设置作者
    Private www.Tulaoshi.comVersionStr          Rem 设置版本
    Private SystemStr              Rem 设置系统名称
    Private SheetName_             Rem 设置表名
    Private SheetTitle_         Rem 设置标题
    Private ExcelData             Rem 设置表数据
    Private ExcelApp             Rem Excel.Application
    Private ExcelBook
    Private ExcelSheets
    Private UsedTime_            Rem 使用的时间
    Public TitleFirstLine        Rem 首行是否标题
    Private Sub Class_Initialize()
        Server.ScriptTimeOut = 99999
        UsedTime_ = Timer
        SystemStr            =    "Lc00_CreateExcelServer"
        AuthorStr            =    "Surnfu  surnfu@126.com  31333716"
        VersionStr            =    "1.0"
        if not IsObjInstalled("Excel.Application") then
            InErr("服务器未安装Excel.Application控件")
        end if
        set ExcelApp = createObject("Excel.Application")
        ExcelApp.DisplayAlerts = false
        ExcelApp.Application.Visible = false
        CreateType_ = 1
        readPath_ = null
    End Sub

    Private Sub Class_Terminate()
        ExcelApp.Quit
        If Isobject(ExcelSheets)     Then Set ExcelSheets    =    Nothing
        If Isobject(ExcelBook)         Then Set ExcelBook        =    Nothing
        If Isobject(ExcelApp)         Then Set ExcelApp        =    Nothing
    End Sub

    Public Property Let ReadPath(ByVal Val)
        If Instr(Val, ":")0 Then
            readPath_ = Trim(Val)
        else
            readPath_=Server.MapPath(Trim(Val))
        end if
    End Property

    Public Property Let SavePath(ByVal Val)
        If Instr(Val, ":")0 Then
            savePath_ = Trim(Val)
        else
            savePath_=Server.MapPath(Trim(Val))
        end if
    End Property
    
    
    Public Property Let CreateType(ByVal Val)
        if Val 1 and Val 2 then
            CreateType_ = 1
        else
            CreateType_ = Val
        end if    
    End Property
    
    Public Property Let Data(ByVal Val)
        if not isArray(Val) then
            InErr("表数据设置有误")
        end if
          ExcelData = Val
    End Property
    Public Property Get SavePath()
    SavePath = savePath_
    End Property
    Public Property Get UsedTime()
          UsedTime = UsedTime_
    End Property
    Public Property Let SheetName(ByVal Val)
        if not isArray(Val) then
            if Val = "" then
                InErr("表名设置有误")
            end if
            TitleFirstLine = true
        else
            ReDim TitleFirstLine(Ubound(Val))
            Dim ik_
            For ik_ = 0 to Ubound(Val)
                TitleFirstLine(ik_) = true
            Next
        end if
          SheetName_ = Val
    End Property
    
    Public Property Let SheetTitle(ByVal Val)
        if not isArray(Val) then
            if Val = "" then
                InErr("表标题设置有误")
            end if
        end if
          SheetTitle_ = Val
    End Property
    
    Rem 检查数据
    Private Sub CheckData()
        if savePath_ = "" then InErr("保存路径不能为空")
        if not isArray(SheetName_) then
            if SheetName_ = "" then InErr("表名不能为空")
        end if
        
        if CreateType_ = 2 then
            if not isArray(ExcelData) then
                InErr("数据载入错误，或者未载入")
            end if
            Exit Sub
        end if
        
        if isArray(SheetName_) then
            if not isArray(SheetTitle_) then
                if SheetTitle_ "" then InErr("表标题设置有误，与表名不对应")
            end if
        end if
        if not IsArray(ExcelData) then
            InErr("表数据载入有误")
        end if
        if isArray(SheetName_) then
            if GetArrayDim(ExcelData) 1 then InErr("表数据载入有误，数据格式错误，维度应该为一")
        else
            if GetArrayDim(ExcelData) 2 then InErr("表数据载入有误，数据格式错误，维度应该为二")
        end if
    End Sub
    Rem 生成Excel
    Public Function Create()
        Call CheckData()
        if not isnull(readPath_) then
            ExcelApp.WorkBooks.Open(readPath_) 
        else
            ExcelApp.WorkBooks.add
        end if
        
        set ExcelBook = ExcelApp.ActiveWorkBook
        set ExcelSheets = ExcelBook.Worksheets
        
        if CreateType_ = 2 then
            Dim ih_
            For ih_ = 0 to Ubound(ExcelData)
                Call SetSheets(ExcelData(ih_), ih_)
            Next
            ExcelBook.SaveAs savePath_
            UsedTime_ = FormatNumber((Timer - UsedTime_)*1000, 3)
            Exit Function
        end if
        
        if IsArray(SheetName_) then
            Dim ik_
            For ik_ = 0 to Ubound(ExcelData)
                Call CreateSheets(ExcelData(ik_), ik_)
            Next
        else
            Call CreateSheets(ExcelData, -1)
        end if
        
        ExcelBook.SaveAs savePath_
        UsedTime_ = FormatNumber((Timer - UsedTime_)*1000, 3)
    End Function 
    Private Sub CreateSheets(ByVal Data_, DataId_)
        Dim Spreadsheet
        Dim tempSheetTitle
        Dim tempTitleFirstLine
        if DataId_-1 then
            if DataId_ ExcelSheets.Count - 1 then
                ExcelSheets.Add()
                set Spreadsheet = ExcelBook.Sheets(1)
            else
                set Spreadsheet = ExcelBook.Sheets(DataId_ + 1)
            end if
            if isArray(SheetTitle_) then
                tempSheetTitle = SheetTitle_(DataId_)
            else
                tempSheetTitle = ""
            end if
            tempTitleFirstLine = TitleFirstLine(DataId_)
            Spreadsheet.Name = SheetName_(DataId_)
        else
            set Spreadsheet = ExcelBook.Sheets(1)
            Spreadsheet.Name = SheetName_
            tempSheetTitle = SheetTitle_
            tempTitleFirstLine = TitleFirstLine
        end if
        Dim Line_ : Line_ = 1
        Dim RowNum_ : RowNum_ = Ubound(Data_, 1) + 1
        Dim LastCols_
        if tempSheetTitle "" then
            'Spreadsheet.Columns(1).ShrinkToFit=true '设定是否自动适应表格单元大小(单元格宽不变）
            LastCols_ = getColName(Ubound(Data_, 2) + 1)
            with Spreadsheet.Cells(1, 1)
                .value = tempSheetTitle
                '设置Excel表里的字体 
                .Font.Bold = True '单元格字体加粗
                .Font.Italic = False '单元格字体倾斜
                .Font.Size = 20 '设置单元格字号
                .font.name="宋体" '设置单元格字体
                '.font.ColorIndex=2 '设置单元格文字的颜色，颜色可以查询，2为白色
            End with
            with Spreadsheet.Range("A1:"& LastCols_ &"1")
                .merge '合并单元格(单元区域)
                '.Interior.ColorIndex = 1 '设计单元络背景色
                .HorizontalAlignment = 3 '居中
            End with
            Line_ = 2
            RowNum_ = RowNum_ + 1
        end if
        Dim iRow_, iCol_
        Dim dRow_, dCol_
        Dim tempLastRange : tempLastRange = getColName(Ubound(Data_, 2)+1) & (RowNum_)
        
        Dim BeginRow : BeginRow = 1
        if tempSheetTitle "" then BeginRow = BeginRow + 1
        if tempTitleFirstLine = true then BeginRow = BeginRow + 1
        
        if BeginRow=1 then
            with Spreadsheet.Range("A1:"& tempLastRange)
                .Borders.LineStyle = 1
                .BorderAround -4119, -4138 '设置外框
                .NumberFormatLocal = "@"   '文本格式
                .Font.Bold = False 
                .Font.Italic = False 
                .Font.Size = 10
                .ShrinkToFit=true 
            end with
        else
            with Spreadsheet.Range("A1:"& tempLastRange)
                .Borders.LineStyle = 1
                .BorderAround -4119, -4138
                .ShrinkToFit=true 
            end with
            
            with Spreadsheet.Range("A"& BeginRow &":"& tempLastRange)
                .NumberFormatLocal = "@" 
                .Font.Bold = False 
                .Font.Italic = False 
                .Font.Size = 10
            end with
        end if
        
        if tempTitleFirstLine = true then
            BeginRow = 1
            if tempSheetTitle "" then BeginRow = BeginRow + 1
        
            with Spreadsheet.Range("A"& BeginRow &":"& getColName(Ubound(Data_, 2)+1) & (BeginRow))
                .NumberFormatLocal = "@"
                .Font.Bold = True 
                .Font.Italic = False 
                .Font.Size = 12
                .Interior.ColorIndex = 37
                .HorizontalAlignment = 3 '居中
                .font.ColorIndex=2
            end with
        end if
        
        For iRow_ = Line_ To RowNum_
            For iCol_ = 1 To (Ubound(Data_, 2) + 1)
                dCol_ = iCol_ - 1
                if tempSheetTitle "" then dRow_ = iRow_ - 2 else dRow_ = iRow_ - 1
                If not IsNull(Data_(dRow_, dCol_)) then 
                    with Spreadsheet.Cells(iRow_, iCol_)
                        .Value = Data_(dRow_, dCol_)
                    End with
                End If 
            Next
        Next
        set Spreadsheet = Nothing
    End Sub 
    Rem 测试组件是否已经安装
    Private Function IsObjInstalled(strClassString)
        On Error Resume Next
        IsObjInstalled = False
        Err = 0
        Dim xTestObj
        Set xTestObj = Server.CreateObject(strClassString)
        If 0 = Err Then IsObjInstalled = True
        Set xTestObj = Nothing
        Err = 0
    End Function
    Rem 取得数组维数
    Private Function GetArrayDim(ByVal arr)   
        GetArrayDim = Null   
        Dim i_, temp   
        If IsArray(arr) Then  
            For i_ = 1 To 60   
                On Error Resume Next  
                temp = UBound(arr, i_)   
                If Err.Number 0 Then  
                    GetArrayDim = i_ - 1
                    Err.Clear 
                    Exit Function  
                End If  
            Next  
            GetArrayDim = i_   
        End If  
    End Function 
    Private Function GetNumFormatLocal(DataType)
        Select Case DataType
            Case "Currency":
                GetNumFormatLocal = "￥#,##0.00_);(￥#,##0.00)"
            Case "Time":
                GetNumFormatLocal = "[$-F800]dddd, mmmm dd, yyyy"
            Case "Char":
                GetNumFormatLocal = "@"
            Case "Common":
                GetNumFormatLocal = "G/通用格式"
            Case "Number":
                GetNumFormatLocal = "#,##0.00_"
            Case else :
                GetNumFormatLocal = "@"
        End Select
    End Function
    Public Sub AddDBData(ByVal RsFlied, ByVal FliedTitle, ByVal tempSheetName_, ByVal tempSheetTitle_, DBTitle)
        if RsFlied.Eof then Exit Sub
        Dim colNum_ : colNum_ = RsFlied.fields.count
        Dim Rownum_ : Rownum_ = RsFlied.RecordCount
        Dim ArrFliedTitle
        
        if DBTitle = true then
            FliedTitle = ""
            Dim ig_
            For ig_=0 to colNum_ - 1
                FliedTitle = FliedTitle & RsFlied.fields.item(ig_).name
                if ig_ colNum_ - 1 then FliedTitle = FliedTitle &","
            Next
        end if
        
        if FliedTitle"" then
            Rownum_ = Rownum_ + 1
            ArrFliedTitle = Split(FliedTitle, ",")
            if Ubound(ArrFliedTitle) colNum_ - 1  then
                InErr("获取数据库表有误，列数不符")
            end if
        end if    
        Dim tempData : ReDim tempData(Rownum_ - 1, colNum_ - 1)
        
        Dim ix_, iy_
        Dim iz
        if FliedTitle"" then iz = Rownum_ - 2  else iz = Rownum_ - 1
        
        For ix_ = 0 To iz
            For iy_ = 0 To colNum_ - 1
                if FliedTitle"" then
                    if ix_=0 then
                        tempData(ix_, iy_) = ArrFliedTitle(iy_)
                        tempData(ix_ + 1, iy_) = RsFlied(iy_)
                    else
                        tempData(ix_ + 1, iy_) = RsFlied(iy_)
                    end if
                else
                    tempData(ix_, iy_) = RsFlied(iy_)
                end if
            Next
            RsFlied.MoveNext
        Next
        
        Dim tempFirstLine 
        if FliedTitle"" then tempFirstLine = true else tempFirstLine = false
        Call AddData(tempData, tempFirstLine, tempSheetName_, tempSheetTitle_)
    End Sub
    Public Sub AddData(ByVal tempDate_, ByVal tempFirstLine_, ByVal tempSheetName_, ByVal tempSheetTitle_)
        if not isArray(ExcelData) then
            ExcelData = tempDate_
            TitleFirstLine = tempFirstLine_
            SheetName_ = tempSheetName_
            SheetTitle_ = tempSheetTitle_
        else
            if GetArrayDim(ExcelData) = 1 then
                Dim tempArrLen : tempArrLen = Ubound(ExcelData)+1
                ReDim Preserve ExcelData(tempArrLen)
                ExcelData(tempArrLen) = tempDate_
                ReDim Preserve TitleFirstLine(tempArrLen)
                TitleFirstLine(tempArrLen) = tempFirstLine_
              tulaoShi.com  ReDim Preserve SheetName_(tempArrLen)
                SheetName_(tempArrLen) = tempSheetName_
                ReDim Preserve SheetTitle_(tempArrLen)
                SheetTitle_(tempArrLen) = tempSheetTitle_
            else
                Dim tempOldData : tempOldData = ExcelData
                ExcelData = Array(tempOldData, tempDate_)
                TitleFirstLine = Array(TitleFirstLine, tempFirstLine_)
                SheetName_ = Array(SheetName_, tempSheetName_)
                SheetTitle_ = Array(SheetTitle_, tempSheetTitle_)
            end if
        end if
    End Sub
    Rem 模板增加数据方法
    Public Sub AddtData(ByVal tempDate_, ByVal tempSheetName_)
        CreateType_ = 2
        if not isArray(ExcelData) then
            ExcelData = Array(tempDate_)
            SheetName_ = Array(tempSheetName_)
        else
            Dim tempArrLen : tempArrLen = Ubound(ExcelData)+1
            ReDim Preserve ExcelData(tempArrLen)
            ExcelData(tempArrLen) = tempDate_
            ReDim Preserve SheetName_(tempArrLen)
            SheetName_(tempArrLen) = tempSheetName_
        End if
    End Sub
    Private Sub SetSheets(ByVal Data_, DataId_)
        Dim Spreadsheet
        set Spreadsheet = ExcelBook.Sheets(SheetName_(DataId_))
        Spreadsheet.Activate
        Dim ix_
        For ix_ =0 To Ubound(Data_)
            if not isArray(Data_(ix_)) then InErr("表数据载入有误，数据格式错误")
            if Ubound(Data_(ix_)) 1 then InErr("表数据载入有误，数据格式错误")
            Spreadsheet.Range(Data_(ix_)(0)).value = Data_(ix_)(1)
        Next
        set Spreadsheet = Nothing
    End Sub
    Public Function GetTime(msec_)
        Dim ReTime_ : ReTime_=""
        if msec_ 1000 then
            ReTime_ = msec_ &"MS"
        else
            Dim second_
            second_ = (msec_ 1000)
            if (msec_ mod 1000)0 then
                msec_ = (msec_ mod 1000) &"毫秒"
            else
                msec_ = ""
            end if
            Dim n_, aryTime(2), aryTimeunit(2)
            aryTimeunit(0) = "秒"
            aryTimeunit(1) = "分"
            aryTimeunit(2) = "小时"
            n_ = 0
            Dim tempSecond_ : tempSecond_ = second_
            While(tempSecond_ / 60 = 1)
                tempSecond_ = Fix(tempSecond_ / 60 * 100) / 100
                n_ = n_ + 1
            WEnd
            Dim m_
            For m_ = n_ To 0 Step -1
                aryTime(m_) = second_ (60 ^ m_)
                second_ = second_ mod (60 ^ m_)
                ReTime_ = ReTime_ & aryTime(m_) & aryTimeunit(m_)
            Next
            if msec_"" then ReTime_ = ReTime_ & msec_
        end if
        GetTime = ReTime_ 
    end Function
    Rem 取得列名
    Private Function getColName(ByVal ColNum)
        Dim Arrlitter : Arrlitter=split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ")
        Dim ReValue_
        if ColNum = Ubound(Arrlitter) + 1 then 
            ReValue_ = Arrlitter(ColNum - 1)
        else
            ReValue_ = Arrlitter(((ColNum-1) 26)) & Arrlitter(((ColNum-1) mod 26))
        end if
        getColName = ReValue_
    End Function
    Rem 设置错误
    Private Sub InErr(ErrInfo)
        Err.Raise vbObjectError + 1, SystemStr &"(Version "& VersionStr &")", ErrInfo
    End Sub
End Class
Dim b(4,6)
Dim c(50,20)
Dim i, j
For i=0 to 4
    For j=0 to 6
        b(i,j) =i&"-"&j
    Next
Next
For i=0 to 50
    For j=0 to 20
        c(i,j) = i&"-"&j &"我的"
    Next
Next
Dim e(20)
For i=0 to 20
    e(i)= array("A"&(i+1), i+1)
Next
'使用示例  需要xx.xls模板支持
'Set a=new CreateExcel
'a.ReadPath = "xx.xls"
'a.SavePath="xx-1.xls"
'a.AddtData e, "Sheet1"
'a.Create()
'response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"br")
'Set a=nothing
'使用示例一
Set a=new CreateExcel
a.SavePath="x.xls"
a.AddData b, true , "测试c", "测试c"
a.TitleFirstLine = false '首行是否为标题行
a.Create()
response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"br")
Set a=nothing
'使用示例二
Set a=new CreateExcel
a.SavePath="y.xls"
a.SheetName="工作簿名称"       '多个工作表 a.SheetName=array("工作簿名称一","工作簿名称二")
a.SheetTitle="表名称"         '可以为空  多个工作表 a.SheetName=array("表名称一","表名称二")
a.Data =b '二维数组             '多个工作表 array(b,c) b与c为二维数组
a.Create()
response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"br")
Set a=nothing
'使用示例三 生成两个表
Set a=new CreateExcel
a.SavePath="z.xls"
a.SheetName=array("工作簿名称一","工作簿名称二")
a.SheetTitle=array("表名称一","表名称二")
a.Data =array(b, c) 'b与c为二维数组
a.TitleFirstLine = array(false, true) '首行是