VB与Excel的导入与导出问题?

On Error GoTo errhandelIf RSzjgroup.RecordCount = 0 Then
   MsgBox " Ã»ÓÐÊý¾Ý", vbInformation, "ÌáʾÐÅÏ¢"
     Text1.Enabled = True
     Combo1.Enabled = True
     Command2.Enabled = False
  Exit Sub
  End If
  
Dim fs As Object
Dim exbook As Excel.Workbook
Dim Exsheet As Excel.Worksheet
Dim exclapp As Excel.Application
Dim rows As Integer
Dim i, j As Integer
Dim DestPathdoc As StringDim arange As String
Dim vrange As String 
Set fs = CreateObject("scripting.filesystemobject")
   CmDlg.InitDir = App.Path & "\temp"
  CmDlg.Filter = "ExcelÎļþ|*.xls"
  
  CmDlg.ShowSave
    If CmDlg.FileName = "" Then Exit Sub
       Set exclapp = New Excel.Application
      DestPathdoc = CmDlg.FileName    If fs.fileexists(DestPathdoc) Then
          Kill DestPathdoc
    End If
    
  fs.copyfile App.Path & "\Template\ר¼¼Ö¤Êé·ÖÀàͳ¼Æ±í.xls", DestPathdoc, True
    Set exbook = exclapp.Workbooks.Open(CmDlg.FileName)
      exclapp.Visible = True    Set Exsheet = exclapp.Worksheets("ר¼¼·ÖÀà")
        Exsheet.Cells(1, 1) = ""
        Exsheet.Cells(1, 1) = "רҵ¼¼ÊõÖ°Îñ×ʸñÖ¤Êéͳ¼ÆÄ걨"
        Exsheet.Cells(2, 10) = Combo1.Text
        If Combo1.Text = "°´Äê¶È" Then Exsheet.Cells(2, 13) = ""
        Exsheet.Cells(2, 14) = Text1.Text
        Exsheet.Cells(3, 1) = "Ìµ¥Î»£¨¸ÇÕ£©£º"
        Exsheet.Cells(3, 3) = Text2.Text
        Exsheet.Cells(3, 13) = Text3(0).Text
        Exsheet.Cells(3, 17) = Text3(1).Text
        Exsheet.Cells(3, 21) = Text3(2).Text
        
        Exsheet.Cells(4, 1) = Mid(Combo1.Text, 2)
        rows = 8
        i = 1
        j = 8
        If RSzjgroup.RecordCount = 0 Then Exit Sub
         RSzjgroup.MoveFirst
         
         Do Until RSzjgroup.EOF
          arange = "a" & CStr(j)
          vrange = "v" & CStr(j)
          
          Exsheet.Range(arange, vrange).Insert
          Exsheet.Range(arange, vrange).RowHeight = 19.5
           If Combo1.Text = "°´ÏµÁÐ" Then
              Exsheet.Cells(rows, 1) = RSzjgroup!techset
               ElseIf Combo1.Text = "°´µ¥Î»" Then
                Exsheet.Cells(rows, 1) = RSzjgroup!Uname
                 Else
                 Exsheet.Cells(rows, 1) = RSzjgroup!certyear
            End If
           Exsheet.Cells(rows, 2) = i
           If RSzjgroup!newtotal = 0 Then
              Exsheet.Cells(rows, 3) = ""
                Else
               Exsheet.Cells(rows, 3) = RSzjgroup!newtotal
           End If
           If RSzjgroup!newgj = 0 Then
              Exsheet.Cells(rows, 4) = ""
                Else
              Exsheet.Cells(rows, 4) = RSzjgroup!newgj
           End If
            If RSzjgroup!newZG = 0 Then
               Exsheet.Cells(rows, 5) = ""
                 Else
             Exsheet.Cells(rows, 5) = RSzjgroup!newZG
           End If
            If RSzjgroup!newZJ = 0 Then
               Exsheet.Cells(rows, 6) = ""
                 Else
              Exsheet.Cells(rows, 6) = RSzjgroup!newZJ
            End If
            If RSzjgroup!newCJ = 0 Then
                Exsheet.Cells(rows, 7) = ""
                  Else
                Exsheet.Cells(rows, 7) = RSzjgroup!newCJ
            End If
                
            If RSzjgroup!changetotal = 0 Then
               Exsheet.Cells(rows, 8) = ""
                Else
              Exsheet.Cells(rows, 8) = RSzjgroup!changetotal
            End If
            If RSzjgroup!changegj = 0 Then
               Exsheet.Cells(rows, 9) = ""
                Else
              Exsheet.Cells(rows, 9) = RSzjgroup!changegj
            End If
            If RSzjgroup!changezg = 0 Then
               Exsheet.Cells(rows, 10) = ""
                Else
              Exsheet.Cells(rows, 10) = RSzjgroup!changezg
            End If
            If RSzjgroup!changezj = 0 Then
               Exsheet.Cells(rows, 11) = ""
                Else
              Exsheet.Cells(rows, 11) = RSzjgroup!changezj
            End If
            If RSzjgroup!changecj = 0 Then
               Exsheet.Cells(rows, 12) = ""
                Else
              Exsheet.Cells(rows, 12) = RSzjgroup!changecj
            End If
            
            If RSzjgroup!renewtotal = 0 Then
                Exsheet.Cells(rows, 13) = ""
                  Else
                Exsheet.Cells(rows, 13) = RSzjgroup!renewtotal
           End If
            If RSzjgroup!renewgj = 0 Then
                Exsheet.Cells(rows, 14) = ""
                  Else
                Exsheet.Cells(rows, 14) = RSzjgroup!renewgj
           End If
            If RSzjgroup!renewzg = 0 Then
                Exsheet.Cells(rows, 15) = ""
                  Else
                Exsheet.Cells(rows, 15) = RSzjgroup!renewzg
           End If
            If RSzjgroup!renewzj = 0 Then
                Exsheet.Cells(rows, 16) = ""
                  Else
                Exsheet.Cells(rows, 16) = RSzjgroup!renewzj
           End If
            If RSzjgroup!renewcj = 0 Then
                Exsheet.Cells(rows, 17) = ""
                  Else
                Exsheet.Cells(rows, 17) = RSzjgroup!renewcj
           End If
            
           
           If RSzjgroup!totalcert = 0 Then
              Exsheet.Cells(rows, 18) = ""
                Else
             Exsheet.Cells(rows, 18) = RSzjgroup!totalcert
            End If
            If RSzjgroup!totalgj = 0 Then
              Exsheet.Cells(rows, 19) = ""
                Else
             Exsheet.Cells(rows, 19) = RSzjgroup!totalgj
            End If
            If RSzjgroup!totalzg = 0 Then
              Exsheet.Cells(rows, 20) = ""
                Else
             Exsheet.Cells(rows, 20) = RSzjgroup!totalzg
            End If
            If RSzjgroup!totalzj = 0 Then
              Exsheet.Cells(rows, 21) = ""
                Else
             Exsheet.Cells(rows, 21) = RSzjgroup!totalzj
            End If
            If RSzjgroup!totalcj = 0 Then
              Exsheet.Cells(rows, 22) = ""
                Else
             Exsheet.Cells(rows, 22) = RSzjgroup!totalcj
            End If
            
            
           rows = rows + 1
           i = i + 1
           j = j + 1
           
            RSzjgroup.MoveNext
         Loop
         
         arange = "a" & CStr(j)
         vrange = "v" & CStr(j)
         
          Exsheet.Range(arange, vrange).Delete
          Exsheet.Range(arange, vrange).RowHeight = 19.5
          
          If Combo1.Text <> "°&acute;&micro;&yen;&Icirc;&raquo;" Then
          Dim ncol As Integer
          Dim nrow As Integer
          Dim nvalue As Integer
          nvalue = 0
          
           For ncol = 3 To 22
              For nrow = 8 To rows - 1
               If Exsheet.Cells(nrow, ncol) <> "" Then
                    nvalue = nvalue + CInt(Exsheet.Cells(nrow, ncol))
               End If
               Next nrow
               If nvalue <> 0 Then
                  Exsheet.Cells(rows, ncol) = nvalue
                Else
                 Exsheet.Cells(rows, ncol) = ""
                End If
                
               nvalue = 0
            Next ncol
        End If
         Command2.Enabled = False
         Combo1.Enabled = True
         Text1.Enabled = True
         Exit Sub
errhandel:
    MsgBox Err.Description, vbInformation, "&Igrave;á&Ecirc;&frac34;&ETH;&Aring;&Iuml;&cent;"

解决方案 »

  1.   

    感谢您使用微软产品。在VB程序中访问excel数据有多种方式，如下例：
    获取数据表中的数据，存储于二维数组中，您可以通过二维数组访问指定列的数据，导出excel中的数据：
    Private Sub GetDataFromExcel()
            Dim rng As Range
            Dim temp()
            Dim i As Integer, j As Integer
      Set rng = xl.ActiveSheet.UsedRange
      i = rng.Rows.Count
      j = rng.Columns.Count
      ReDim temp(1 To i, 1 To j)
            temp = rng
            Set rng = Nothing
            ActiveWorkbook.Close
      xl.Quit
            Set xl = Nothing
      For i = 1 To UBound(temp, 1)
                   For j = 1 To UBound(temp, 2)
                          Debug.Print temp(i, j)
                   Next
            Next
    End Sub反过来，您也可以实现把数据批量导入excel:
    Private Sub Command4_Click()
      Dim i As Integer
      Dim j As Integer  For i = 1 To 20
         For j = 1 To 15
            temp(i, j) = Rnd * 10 ' this more efficient
         Next
      Next
      xl.Range("A1:O20").Value = temp  
      
    End Sub其他方法还有：
    1. 把数据一个个填入表格单元
    2．把记录基中的数据填入Excel表的范围
    3．把对ODBC或OLEDB查询到的数据作为一个Excel worksheet
    4. 利用clipboard传递数据您可以参考下面链接中的方法中的例子。
    Q247412 INFO: Methods for Transferring Data to Excel from Visual Basic
     http://support.microsoft.com/support/kb/articles/q247/4/12.asp-  微软全球技术中心 VB技术支持本贴子以“现状”提供且没有任何担保，同时也没有授予任何权利。具体事项可参见使用条款
    (http://support.microsoft.com/directory/worldwide/zh-cn/community/terms_chs.asp)。
    为了为您创建更好的讨论环境，请参加我们的用户满意度调查
    (http://support.microsoft.com/directory/worldwide/zh-cn/community/survey.asp?key=(S,49854782))。
    ======================