dim str1 As String
Dim Xl As Object
Dim K As New Excel.Application
Set Xl = K.Workbooks.Open(App.Path & "\file\工资" & Format(Date, "YYYY_MM_DD") & ".xls")
str1=Xl.Worksheets(1).Cells(j, i).Value
str1就是读回的表1的地J行I列的数据
`调用dbftoxls的模块
Private Sub Cmdgeneratetable_Click()
Dim staticsfile As String
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim idyes As Integer
Dim dbfstring As String
On Error GoTo errhandler1
idyes = 6
s1 = txtyear.Text
s1 = Mid(s1, 3, 2)
s2 = txtmonth.Text
If Len(s2) = 1 Then
s2 = "0" + s2
End If
staticsfile = apppath + staticspre + s1 + s2 + ".xls"
If FileLen(staticsfile) > 0 Then
choice = MsgBox("该年月报表已存在,是否重新生成?", vbYesNo + vbExclamation + vbDefaultButton1, "")
If choice = idyes Then
Workbooks.Open FileName:=staticsfile
For i = 0 To companynum - 1
For j = 0 To tablenum - 1
dbfstring = dbfpre + Trim(Str$(j + 1)) + s2
sqlstring = sqlstringfunc(dbfstring, fieldlist(), tablefieldnum(j))
Call dbftoxls(s(i, j), sqlstring)
Next j
Next i
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
End If
Exit Sub
errhandler1:
Select Case Err
Case 53
Workbooks.Open FileName:=modulefile
s3 = s1 + "年" + s2 + "月"
Sheets("资产负债表").Range("e4").FormulaR1C1 = "'" + s3
ActiveWorkbook.SaveAs FileName:=staticsfile, FileFormat :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= False, CreateBackup:=False
For i = 0 To companynum - 1
For j = 0 To tablenum - 1
dbfstring = dbfpre + Trim(Str$(j + 1)) + s2
sqlstring = sqlstringfunc(dbfstring, fieldlist(), tablefieldnum(j))
Call dbftoxls(s(i, j), sqlstring)
Next j
Next i
ActiveWorkbook.Save
ActiveWorkbook.Close
End Select
End Sub
`dbftoxls子程序
Sub dbftoxls(activesheetname, sqlstring)
Sheets(activesheetname).Activate
Cells.Select
Selection.Clear
Range("a1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array(Array("ODBC;CollatingSequence=ASCII;DBQ=C:\T\palm1;DefaultDir=C:\T\palm1;Deleted=1;Driver={MicrosoftdBase Driver (*.dbf)};DriverId=533;FIL"), Array("=dBase III;ImplicitCommitSync=Yes;MaxBufferSize=512;MaxScanRows=8;PageTimeout=600;SafeTransactions=0;Statistics=0;Threads=3;Use" ), Array("rCommitSync=Yes;")), Destination:=Range("A1"))
.Sql = Array( sqlstring)
.FieldNames = True
.RefreshStyle = xlInsertDeleteCells
.RowNumbers = False
.FillAdjacentFormulas = False
.RefreshOnFileOpen = False
.HasAutoFormat = True
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SavePassword = True
.SaveData = True
End With
End Sub