如何用VB创建多Sheet的excel(Sheet能重新命名)

比如我有数组:Arr_Name()
创建 Excel文件，保存地址为 str_Excel_File_Address,其中该 Excel的Sheet数量为 Ubound(Arr_Name())+2.
Sheet的命名规则为:
第一个Sheet名:Summary
第二个~最后一个的SheetName为 数组Arr_Name()中的值..
这个如何编写呢..

5 个解决方案

#1

咋就没人光顾呢...呵呵
自己顶下
～

#2

自己倒弄了一个，但发现 Excel进程不退出.一直存在.不知道为什么？

'创建 Excel文件
Sub Load_Operate_Excel(ByVal str_DB_File_Address As String, ByRef str_Table_Name() As String, ByVal Int_Count As Byte)
'Arr_DB_BackUp_File_Address(i) 文件地址
'Arr_Table_Name(k)  'Sheet 名

Dim i As Byte

'打开 Excel文件
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = False  '操作不可见
Set xlBook = xlApp.Workbooks.Add()  
For i = 0 To UBound(str_Table_Name())
  
    If str_Table_Name(i) <> "" Then
        Set xlSheet = ActiveWorkbook.Worksheets.Add         '添加新sheet
        xlSheet.Name = str_Table_Name(i)                     '重命名新sheet
    Else
        Exit For
    End If
Next i


DoEvents
xlApp.ActiveWorkbook.SaveAs str_DB_File_Address
xlApp.Quit  ‘但并没有退出

Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

DoEvents

End Sub

#3

是你观察得问题把,用你得代码也完全可以添加,改名,退出excel,退出有个过程,用了点时间(不是立即)
下面得代码也无所谓顺序,都能通过.不过还是应按顺序释放

Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

Dim i As Byte
Dim str_Table_Name(1) As String
Dim str_DB_File_Address  As String
str_Table_Name(0) = "123"
str_Table_Name(1) = "234"
str_DB_File_Address = "D:\AS.XLS"
'打开 Excel文件
Set xlapp = CreateObject("Excel.application")
xlapp.Visible = False  '操作不可见
xlapp.Visible = True
Set xlbook = xlapp.Workbooks.Add()
For i = 0 To UBound(str_Table_Name())
  
    If str_Table_Name(i) <> "" Then
        Set xlsheet = xlapp.ActiveWorkbook.Worksheets.Add         '添加新sheet
        xlsheet.Name = str_Table_Name(i)                     '重命名新sheet
    Else
        Exit For
    End If
Next i
DoEvents
xlapp.ActiveWorkbook.SaveAs str_DB_File_Address
xlapp.Quit  '‘但并没有退出[/color]
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing

#4

参考

Private   Sub   PrintButton_Click() 
On   Error   GoTo   ErrHandle 
        Dim   xlApp   As   New   Excel.Application 
        Dim   xlBook   As   New   Excel.Workbook 
        Dim   xlSheet   As   New   Excel.Worksheet 
        Dim   strsql   As   String 
        Dim   rsPict   As   New   ADODB.Recordset 
        
        If   RichTextBox1.Text   =   " "   Then 
                MsgBox   "沒有輸入工號﹐每次可輸入9人工號 ",   vbExclamation,   "提醒您 " 
                Exit   Sub 
        End   If 
        
        '19512,21303,24366,33110,51019,67066,76002,85002,99017 
        Screen.MousePointer   =   11 
        strsql   =   "SELECT   A.person_no,A.person_name,B.dept_name,A.photo "   &   _ 
                        "   FROM   person   A   LEFT   JOIN   (SELECT   position.position_no,position.name,position.dept_no,dept.name   AS   dept_name   FROM   position   LEFT   JOIN   dept   ON   left(position.dept_no,1)+ '0000 '=dept.dept_no)B "   &   _ 
                        "   ON   A.position_no=B.position_no   "   &   _ 
                        "   where   A.photo   is   not   null   and   A.enable= '1 '   and   A.person_no   in( "   &   RichTextBox1.Text   &   ") " 
                        
        rsPict.Open   strsql,   pubConn,   1,   1 
        If   rsPict.EOF   Then 
                Exit   Sub 
        End   If 
        
        Set   xlApp   =   CreateObject( "Excel.Application ") 
        Set   xlBook   =   xlApp.Workbooks.Open( "\\SWEB\Excel\PrintPhoto.xls ") 
        Set   xlSheet   =   xlBook.Worksheets(2) 
        xlApp.Visible   =   False 

        rsPict.MoveFirst 
        Dim   ZX   As   Single,   ZY   As   Single 
        Dim   i   As   Integer,   j   As   Integer 
        
        With   Image1 
                .Stretch   =   False 
                .Visible   =   False 
                .Picture   =   LoadPicture( "\\SWEB\datafile\photo\employee\24115.jpg ") 
                ZX   =   .Width   /   3000           '假設目標寬度155圖元 
                ZY   =   .Height   /   3500         '假設目標高度165圖元 

              .Stretch   =   True 
              .Height   =   Int(.Height   /   ZY) 
              .Width   =   Int(.Width   /   ZX) 
        End   With 
        
        i   =   0 
        j   =   0 
        Do   While   Not   rsPict.EOF 
                xlSheet.Shapes.AddPicture   rsPict.Fields(3).Value,   False,   True,   X1(i),   Y1(j),   ZX   *   32,   ZY   *   37 
                xlSheet.Shapes.AddPicture   "\\SWEB\datafile\photo\employee\logo.jpg ",   False,   True,   X2(i),   Y2(j),   ZX   *   15,   ZY   *   8 
                
                xlSheet.Cells(X3(i),   Y3(i))   =   AddSpace(rsPict.Fields(2).Value) 
                xlSheet.Cells(X3(i)   +   2,   Y3(i))   =   Space(5)   &   "工號: "   &   rsPict.Fields(0).Value 
                xlSheet.Cells(X3(i)   +   3,   Y3(i))   =   Space(5)   &   "姓名: "   &   IIf(Len(rsPict.Fields(1).Value)   =   2,   Left(rsPict.Fields(1).Value,   1)   +   Space(2)   +   Right(rsPict.Fields(1).Value,   1),   rsPict.Fields(1).Value) 
                rsPict.MoveNext 
                i   =   i   +   1 
                j   =   j   +   1 
        Loop 
        
        xlSheet.Cells(1,   1).Select 
        xlApp.Visible   =   True 
        
        Set   xlApp   =   Nothing 
        Set   xlBook   =   Nothing 
        Set   xlSheet   =   Nothing 
        Screen.MousePointer   =   0 
        
        Exit   Sub 
ErrHandle: 
        MsgBox   "發生意外錯誤,請查看輸入的工號是否正確﹖ ",   vbExclamation,   "提醒您 " 
        Screen.MousePointer   =   0 
        
End   Sub

#5

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing