Private Sub Command1_Click() Dim path As String Dim FileType As String Dim excelcj As Excel.Application Dim exbook1 As Excel.Workbook Dim exsheet1 As Excel.Sheets Dim Fname As String '定义文件名 On Error Resume Next m = 0 i = 1 path = Combo1.Text FileType = "*" FileName = "d:\1.xls" 10 SearchFiles path, FileType '调用子程序,返回查找清单。 If a <= 62000 Then GoTo 30 '如果数据量超过62000条就一次性写入excel If Dir(FileName) = "" Then '看文件是否存在,有则打开,没有则建一个 Set excelcj = CreateObject("excel.application") excelcj.SheetsInNewWorkbook = 1 Set exbook1 = excelcj.Workbooks().Add Set exsheet1 = exbook1.activesheets("sheet1") Else Set excelcj = GetObject("excel.application")
Set exbook1 = excelcj.Workbooks.Open("d:\1.xls")
Set exsheet1 = exbook1.activesheets End If
If m = 0 Then GoTo 20 Else End If
Do Until exsheet1.Application.Cells(m + 1, 1) = "" ' m = m + 1 Loop
20 If a <= 62100 Then Do Until i = a exsheet1.Application.Cells(i, 1) = Files(i) i = i + 1 Loop Else For i = i To 62100 exsheet1.Application.Cells(i, 1) = Files(i) Next i i = 1 exbook1.Worksheets.Add Set exsheet1 = exbook1.ActiveSheet For i = i To a - 62100
exsheet1.Application.Cells(i, 1) = Files(i + 62100) Next i End If excelcj.DisplayAlerts = False exbook1.SaveAs ("d:\1.xls") excelcj.DisplayAlerts = True exbook1.Close excelcj.Quit a = 1 30 MsgBox "OK" Unload Me