第二次导出EXCEL的时候提示"实时错误1004,对象'Range'的方法'_Golbal'失败"!?

Private Sub cmdToExcel_Click()
      'On Error GoTo errorhandle:
    Dim R As Long, C As Long
    '********************************'copy导出文件
    'Dim fso As New FileSystemObject, filTar As File
 
    
    cdgExport.CancelError = True
    cdgExport.Filter = "导出Excel文件类型（*.xls）|*.xls"
    cdgExport.InitDir = ExcelPath '"c:\"
    'Set filTar = fso.GetFile(App.Path & "\excel_port.xl_")
    cdgExport.ShowSave
    If cdgExport.FileName = "" Then
        Exit Sub
    Else
        '判断是否已经有了这个文件。
        'MsgBox cdgExport.FileName
    If gfunFileExist(cdgExport.FileName) Then
        'MsgBox "已经存在" & cdgExport.FileName & "这个文件，是否覆盖?", vbYesNo + vbNo + vbInformation + vbDefaultButton2, "系统提示"
        'MsgBox "已经存在" & cdgExport.FileName & "这个文件，请选择别的文件名来存盘！"
        'Exit Sub
        Kill cdgExport.FileName
    End If
        FileCopy App.Path & "\excel_port.xl_", cdgExport.FileName
        'filTar.Copy (cdgExport.FileName)
    End If
  
    '********************************
    
  
    '********************************
    Screen.MousePointer = vbHourglass
    
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    Set xlBook = xlApp.Workbooks.Open(CStr(cdgExport.FileName))  '打开已经存在的EXCEL工件簿文件
    
    xlApp.Visible = True '设置EXCEL对象可见（或不可见）    Set xlsheet = xlBook.Worksheets(1) '设置活动工作表Set xlSheet = xlBook.Worksheets("sheet1") '
    
       ' DoEvents
    
        'Set excel_app = CreateObject("Excel.Application")
        'excel_app.Workbooks.Open FileName:=cdgExport.FileName '
    
        'If Val(excel_app.Application.Version) >= 8 Then
        '    Set excel_sheet = excel_app.ActiveSheet
        'Else
        '    Set excel_sheet = excel_app
        'End If
        '*************************
        'excel_sheet.Cells(2, 2) = "条　　件　　查　　询"    '"标题"
       
        xlsheet.Activate '激活工作表?
        xlsheet.Cells(2, 4) = Me.Caption  '给单元格1行驶列赋值
        xlsheet.Cells(3, 4) = DTPicker1.Value & "－" & DTPicker2.Value
                
        Dim begrow As Integer '从第行开始表体
        begrow = 3
        With xlsheet
            
            
            For R = 1 To MSG.Rows
                For C = 1 To MSG.Cols
                    .Cells(R + begrow, C) = MSG.TextMatrix(R - 1, C - 1)
                Next C
            Next R
            ' MsgBox "r=" & R & "msg.grows=" & MSG.Rows
            'Range("C4:G10").Select
            
            If R = 1 Then
                Range("A" & begrow + 1 & ":" & "I" & begrow + R).Select
            Else
                Range("A" & begrow + 1 & ":" & "I" & begrow + R - 1).Select
            End If
            
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlDouble
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            
            With Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            
            If R <> 1 Then
            With Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            End If
            'Range("D2").Select
            'Range("A" & begrow + 1 & ":" & "I" & begrow + R + 1).Borders   '边框设置
             '   xlsheet.Range("A4:I9").Borders '边框设置
                 
             '   .LineStyle = xlBorderLineStyleContinuous
             '  .Weight = xlThin
             '  .ColorIndex = 1
           
           
            .Cells(R + begrow, 1) = StatusBar1.Panels(1).Text
            .Cells(R + begrow, 2) = StatusBar1.Panels(2).Text
            .Cells(R + begrow, 3) = StatusBar1.Panels(3).Text
            .Cells(R + begrow, 4) = StatusBar1.Panels(4).Text
            .Cells(R + begrow, 6) = StatusBar1.Panels(5).Text
            .Cells(R + begrow, 8) = StatusBar1.Panels(6).Text
        End With
        
        
       
   
        'excel_sheet.Cells(5, 1) = "序号"
        ' If j >= 2 Then
        '    excel_sheet.Cells(4 + i, j - 4) = "合计"
        '    excel_sheet.Cells(4 + i, j - 3) = txtTotalMoney.Text    '合计
        ' End If
     
          '*************************
 
        'excel_app.ActiveWorkbook.Close True 'False　'是否对EXCELL进行更改。
        'excel_app.Quit
        'Set excel_sheet = Nothing
        'Set excel_app = Nothing        Screen.MousePointer = vbDefault
        
        '三.打印预览
        xlApp.ActiveSheet.PageSetup.Orientation = xlPortrait     ' 设置打印方向
        xlApp.ActiveSheet.PageSetup.PaperSize = xlPaperA4      ' 设置打印纸的打下
        xlApp.Caption = "打印预览"               '设置预览窗口的 标题
        xlApp.ActiveSheet.PrintPreview            '打印预览
        xlApp.ActiveSheet.PrintOut                '打印输出        xlBook.Close (True) '关闭EXCEL工作簿
        xlApp.Quit '关闭EXCEL
        Set xlApp = Nothing '释放EXCEL对象        '注：为了在退出应用程序后EXCEL不提示用户是否保存已修改的文件,需使 用如下语句：
        'xlApp.DisplayAlerts = False
        'xlApp.Quit       '退出EXCEL
        'xlApp.DisplayAlerts = True
    
    MsgBox "转出完成！"
    Exit Sub
 '********************************
    
errorhandle:
   'MsgBox "您所使用的这个文件，可能正在被系统共享，请用别的名字来保存。"
    Screen.MousePointer = vbDefault
    If Not (Err.Number = cdlCancel) Then
        MsgBox Err.Description & Err.Number
    End If
    
End Sub'-------------
第二次导出时提示了上面的错误，求助！

解决方案 »

  1.   

    "实时错误1004,对象'Range'的方法'_Golbal'失败"!?
      

  2.   

    Private Sub cmdToExcel_Click()
          'On Error GoTo errorhandle:
        Dim R As Long, C As Long
        '********************************'copy导出文件
        'Dim fso As New FileSystemObject, filTar As File
     
        
        cdgExport.CancelError = True
        cdgExport.Filter = "导出Excel文件类型（*.xls）|*.xls"
        cdgExport.InitDir = ExcelPath '"c:\"
        'Set filTar = fso.GetFile(App.Path & "\excel_port.xl_")
        cdgExport.ShowSave
        If cdgExport.FileName = "" Then
            Exit Sub
        Else
            '判断是否已经有了这个文件。
            'MsgBox cdgExport.FileName
        If gfunFileExist(cdgExport.FileName) Then
            'MsgBox "已经存在" & cdgExport.FileName & "这个文件，是否覆盖?", vbYesNo + vbNo + vbInformation + vbDefaultButton2, "系统提示"
            'MsgBox "已经存在" & cdgExport.FileName & "这个文件，请选择别的文件名来存盘！"
            'Exit Sub
            Kill cdgExport.FileName
        End If
            FileCopy App.Path & "\excel_port.xl_", cdgExport.FileName
            'filTar.Copy (cdgExport.FileName)
        End If
      
        '********************************
        
      
        '********************************
        Screen.MousePointer = vbHourglass
        
        Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlsheet As Excel.Worksheet
        Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
        Set xlBook = xlApp.Workbooks.Open(CStr(cdgExport.FileName))  '打开已经存在的EXCEL工件簿文件
        
        xlApp.Visible = True '设置EXCEL对象可见（或不可见）    Set xlsheet = xlBook.Worksheets(1) '设置活动工作表Set xlSheet = xlBook.Worksheets("sheet1") '
        
           ' DoEvents
        
            'Set excel_app = CreateObject("Excel.Application")
            'excel_app.Workbooks.Open FileName:=cdgExport.FileName '
        
            'If Val(excel_app.Application.Version) >= 8 Then
            '    Set excel_sheet = excel_app.ActiveSheet
            'Else
            '    Set excel_sheet = excel_app
            'End If
            '*************************
            'excel_sheet.Cells(2, 2) = "条　　件　　查　　询"    '"标题"
           
            xlsheet.Activate '激活工作表?
            xlsheet.Cells(2, 4) = Me.Caption  '给单元格1行驶列赋值
            xlsheet.Cells(3, 4) = DTPicker1.Value & "－" & DTPicker2.Value
                    
            Dim begrow As Integer '从第行开始表体
            begrow = 3
            With xlsheet
                
                
                For R = 1 To MSG.Rows
                    For C = 1 To MSG.Cols
                        .Cells(R + begrow, C) = MSG.TextMatrix(R - 1, C - 1)
                    Next C
                Next R
                ' MsgBox "r=" & R & "msg.grows=" & MSG.Rows
                'Range("C4:G10").Select
                
                If R = 1 Then
                    Range("A" & begrow + 1 & ":" & "I" & begrow + R).Select
                Else
                    Range("A" & begrow + 1 & ":" & "I" & begrow + R - 1).Select
                End If
                
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                With Selection.Borders(xlEdgeLeft)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
                With Selection.Borders(xlEdgeRight)
                    .LineStyle = xlDouble
                    .Weight = xlThick
                    .ColorIndex = xlAutomatic
                End With
                
                With Selection.Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
                
                If R <> 1 Then
                With Selection.Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
                End If
                'Range("D2").Select
                'Range("A" & begrow + 1 & ":" & "I" & begrow + R + 1).Borders   '边框设置
                 '   xlsheet.Range("A4:I9").Borders '边框设置
                     
                 '   .LineStyle = xlBorderLineStyleContinuous
                 '  .Weight = xlThin
                 '  .ColorIndex = 1
               
               
                .Cells(R + begrow, 1) = StatusBar1.Panels(1).Text
                .Cells(R + begrow, 2) = StatusBar1.Panels(2).Text
                .Cells(R + begrow, 3) = StatusBar1.Panels(3).Text
                .Cells(R + begrow, 4) = StatusBar1.Panels(4).Text
                .Cells(R + begrow, 6) = StatusBar1.Panels(5).Text
                .Cells(R + begrow, 8) = StatusBar1.Panels(6).Text
            End With
            
            
           
       
            'excel_sheet.Cells(5, 1) = "序号"
            ' If j >= 2 Then
            '    excel_sheet.Cells(4 + i, j - 4) = "合计"
            '    excel_sheet.Cells(4 + i, j - 3) = txtTotalMoney.Text    '合计
            ' End If
         
              '*************************
     
            'excel_app.ActiveWorkbook.Close True 'False　'是否对EXCELL进行更改。
            'excel_app.Quit
            'Set excel_sheet = Nothing
            'Set excel_app = Nothing        Screen.MousePointer = vbDefault
            
            '三.打印预览
            xlApp.ActiveSheet.PageSetup.Orientation = xlPortrait     ' 设置打印方向
            xlApp.ActiveSheet.PageSetup.PaperSize = xlPaperA4      ' 设置打印纸的打下
            xlApp.Caption = "打印预览"               '设置预览窗口的 标题
            xlApp.ActiveSheet.PrintPreview            '打印预览
            xlApp.ActiveSheet.PrintOut                '打印输出        xlBook.Close (True) '关闭EXCEL工作簿
            xlApp.Quit '关闭EXCEL
            Set xlApp = Nothing '释放EXCEL对象        '注：为了在退出应用程序后EXCEL不提示用户是否保存已修改的文件,需使 用如下语句：
            'xlApp.DisplayAlerts = False
            'xlApp.Quit       '退出EXCEL
            'xlApp.DisplayAlerts = True
        
        MsgBox "转出完成！"
        Exit Sub
     '********************************
        
    errorhandle:
       'MsgBox "您所使用的这个文件，可能正在被系统共享，请用别的名字来保存。"
        Screen.MousePointer = vbDefault
        If Not (Err.Number = cdlCancel) Then
            MsgBox Err.Description & Err.Number
        End If
        
    End Sub'-------------
    第二次导出时提示了上面的错误，求助！