血染疆场 发表于：2017-10-13 22:14:58
已完成代码如下,access中一个窗体查询结束后通过一个按钮导出Excel,Excel中的K列是数字格式,表示时间长度,单位是月,L列表示一个日期,格式是中日期,M列的数据access表中没有,希望通过代码向Excel中的M列导入一个公式,L列的日期加上K列的月数得到的结果是一个日期或者数字.
Private Sub 汇总到押品移交台账_Click()
Dim rs As DAO.Recordset
Dim objxls As Object
Dim N As Long
Dim strCode As String
Dim lngTSales As Long
Dim lngTSTock As Long
If IsNull(Me.贷款品种) Then
Set rs = CurrentDb.OpenRecordset("SELECT 总查询.* FROM 总查询 ORDER BY 总查询.序号;")
Else
Set rs = CurrentDb.OpenRecordset("SELECT 总查询.* FROM 总查询 WHERE (((总查询.[品种-贷款品种]) = '" & Me.贷款品种 & "')) ORDER BY 总查询.序号;")
End If
rs.MoveFirst
N = 5
Set objxls = CreateObject("excel.Application")
objxls.Workbooks.Add
objxls.Visible = True
With objxls.Sheets("Sheet1")
.Range("AE1:AF1").MergeCells = True
.Range("A1:A2,B1:B2,C1:C2,D1:D2,E1:E2,F1:F2,G1:G2,H1:H2,I1:I2,J1:J2 ,K1:K2 , L1: L2 , M1: M2 , N1: N2 , O1: O2 , P1: P2 , Q1: Q2 , R1: R2 , S1: S2,T1:T2,U1:U2,V1:V2,W1:W2,X1:X2,Y1:Y2,Z1:Z2,AA1:AA2,AB1:AB2,AC1:AC2,AD1:AD2,AG1:AG2,AH1:AH2,AI1:AI2").MergeCells = True
.Range("A1,J1,K1,S1,T1").ColumnWidth = 5
.Range("B1,C1,D1,E1,G1,H1,I1,L1,M1,N1,O1,P1,Q1,U1,V1,W1,X1,Y1,Z1,AA1,AB1,AC1,AD1,AG1,AH1,AI1").ColumnWidth = 10
.Range("F1,R1").ColumnWidth = 25
.Range("AE1:AF1").ColumnWidth = 10
.Range("A1") = "序号"
.Range("B1") = "二级机构名称"
.Range("C1") = "机构名称"
.Range("D1") = "产品名称"
.Range("E1") = "楼盘或项目名称"
.Range("F1") = "贷款项目号"
.Range("G1") = "借款人"
.Range("H1") = "客户号"
.Range("I1") = "贷款账号"
.Range("J1") = "合同金额"
.Range("K1") = "贷款期限"
.Range("L1") = "贷款发放日"
.Range("M1") = "贷款到期日"
.Range("N1") = "贷款余额"
.Range("O1") = "担保人"
.Range("P1") = "担保合同号"
.Range("Q1") = "押品名称"
.Range("R1") = "押品地址"
.Range("S1") = "押品面积"
.Range("T1") = "押品权利价值"
.Range("U1") = "押品状态"
.Range("V1") = "备案登记编号"
.Range("W1") = "房产证编号"
.Range("X1") = "他项权证编号"
.Range("Y1") = "承保公司"
.Range("Z1") = "保费金额"
.Range("AA1") = "保单号码"
.Range("AB1") = "移交押品管理岗日期"
.Range("AC1") = "移交档案管理部门日期"
.Range("AD1") = "退换押品日期"
.Range("AE1") = "变更日期"
.Range("AF1") = "变更说明"
.Range("AG1") = "备注"
.Range("AH1") = "经办人"
.Range("AI1") = "复核"
.Range("AE1:AF1") = "押品变更记录"
With .Range("A1:AI2")
.Font.Bold = True '设为粗体
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
End With
Do While rs.EOF = False
.Range("A" & N) = rs("序号")
.Range("B" & N) = rs("支行-所属支行")
.Range("D" & N) = rs("品种-贷款品种")
.Range("E" & N) = rs("开发商")
.Range("F" & N) = rs("项目号")
.Range("G" & N) = rs("借款人")
.Range("H" & N) = rs("客户号")
.Range("I" & N) = rs("贷款账号")
.Range("J" & N) = rs("金额-借款金额(万元)")
.Range("K" & N) = rs("期限-借款期限(月)")
.Range("L" & N).NumberFormatLocal = "yyyymmdd"
.Range("L" & N) = rs("放款日期")
.Range("R" & N) = rs("押品地址")
.Range("S" & N) = rs("面积-押品面积(m2)")
.Range("T" & N) = rs("总价-交易总价")
.Range("W" & N) = rs("房产证号")
.Range("X" & N) = rs("他项号")
rs.MoveNext
N = N + 1
\Loop
With .Range("A3:AI" & N - 1)
.Borders.LineStyle = xlContinuous
End With
End With
objxls.ActiveWorkbook.SaveAs FileName:=CurrentProject.Path & "\" & Me.年度 & "" & Me.所属支行 & " " & Me.贷款品种 & "押品移交台帐.xls"
Set objxls = Nothing
End Sub
拜谢大神
-
1, Set rs = CurrentDb.OpenRecordset("SELECT 总查询.*,dateadd("m",[表中间隔月],[表中的日期］)as 表达日期 FROM 总查询 WHERE (((总查询.[品种-贷款品种]) = '" & Me.贷款品种 & "')) ORDER BY 总查询.序号;")
-
2， .Range("M" & N) = rs("表达日期")
运行报错啊老师,就在dateadd函数那里,说语法错误
On Error GoTo err
Dim rs As DAO.Recordset
Dim objxls As Object
Dim N As Long
Dim strWhere As String '定义条件字符串
Dim sql As String
strWhere = "" '设定初始值－空字符串
If Not IsNull(Me.Text) Then
strWhere = strWhere & "([贷款品种] like '*" & Me.Text & "*') AND "
End If
If Not IsNull(Me.Text2) Then
strWhere = strWhere & "([所属支行] like '*" & Me.Text2 & "*') AND "
End If
'如果输入了条件，那么strWhere的最后肯定有" AND "，这是我们不需要的，
'要用LEFT函数截掉这5个字符。
If Len(strWhere) > 0 Then
'有输入条件
strWhere = Left(strWhere, Len(strWhere) - 5)
End If
sql = "SELECT 总表.*,dateadd('m',NZ([借款期限]),[操作日期]) as 到期日 FROM 总表 " _
& "WHERE(" & strWhere & ")"
If IsNull(Me.Text) And IsNull(Me.Text2) Then
Set rs = CurrentDb.OpenRecordset("SELECT 总表.*,dateadd('m',NZ([借款期限]),[操作日期]) as 到期日 FROM 总表 ORDER BY 总表.操作日期;")
Else
Set rs = CurrentDb.OpenRecordset(sql)
End If
rs.MoveFirst
N = 5
Set objxls = CreateObject("excel.Application")
objxls.Workbooks.Add
objxls.Visible = True
With objxls.Sheets("Sheet1")
.Range("A1:A4,B1:B4,C1:C4,D1:D4,E1:F2,E3:E4,F3:F4,G1:G4,H1:H4,I1:I4").MergeCells = True
.Range("E1").ColumnWidth = 4
.Range("a1,B1,F1,I1,H1").ColumnWidth = 14
.Range("C1,G1").ColumnWidth = 8
.Range("D1,E1:F1").ColumnWidth = 18
.Range("A1") = "序号"
.Range("B1") = "二级机构名称 "
.Range("C1") = "机构名称"
.Range("D1") = "贷款项目号"
.Range("E1:F1") = "押品变更纪录"
.Range("E3") = " 变更日期"
.Range("F3") = " 变更说明"
.Range("G1") = " 备注"
.Range("H1") = "借款期限(月)"
.Range("I1") = " 到期日"
With .Range("A1:I4")
.Font.Bold = True '设为粗体
.HorizontalAlignment = -4108
.VerticalAlignment = -4108
.Borders.LineStyle = xlContinuous
.Font.Color = -16776961
.Font.Name = "华文隶书"
.Font.Size = 12
End With
' Do While rs.EOF = False
Do While Not rs.EOF
.Range("A" & N) = rs("操作日期")
.Range("A" & N).NumberFormatLocal = "yyyy-m-d"
.Range("B" & N) = rs("贷款品种")
.Range("C" & N) = rs("所属支行")
.Range("D" & N) = rs("所属柜员")
.Range("E" & N) = rs("放款日期")
.Range("F" & N) = rs("项目号")
.Range("G" & N) = rs("批注")
.Range("H" & N) = rs("借款期限")
.Range("H" & N).NumberFormatLocal = "0_);(0)"
.Range("I" & N) = rs("到期日")
.Range("I" & N).NumberFormatLocal = "yyyy-m-d"
rs.MoveNext
N = N + 1
Loop
With .Range("A5:I" & N - 1)
.Borders.LineStyle = xlContinuous
End With
End With
objxls.ActiveWorkbook.SaveAs FileName:=CurrentProject.Path & "\导出测试" & Format(Date, "YYYY-MM-DD") & ".xls"
Set objxls = Nothing
err: Exit Sub
经测试成功。
但表设计字段不能有（），比喻：借款期限 ，可以在标题中：借款期限（月）
