VBA源码(销售月度统计报表)
'引用Microsoft OLE DB Service Component 1.0 Type Libary
'引用Microsoft ActiveX Data Objects 2.x Library
'引用Microsoft ADO Data Control
Dim strSQL1 As String
Private Sub combobox5_Change()
Set cn = CreateObject("ADODB.Connection")
'Set cmd = CreateObject("ADODB.Command")
cn.ConnectionString = "Driver={SQL Server};server=127.0.0.1;uid=sa;pwd=;database=KIS_Sample"
cn.Open
Set rs = CreateObject("ADODB.recordset")
'strSQL1 = "select fnumber,fname from t_icitemcore where fitemid<=230 order by fnumber"
strSQL1 = "select top 200 fnumber from t_icitemcore where fnumber like '%" & ComboBox5.Value & "%'" & " order by fnumber"
'rs.Open strSQL1, cn, adOpenKeyset, adLockReadOnly
'MsgBox strSQL1
rs.Open strSQL1, cn, 1, 1
Dim i As Integer
If Not rs.EOF Then
'ComboBox5.Clear
For i = 0 To rs.RecordCount - 1
ComboBox5.AddItem rs("fnumber")
'ComboBox5.itemData(i) = rs("id").Value
rs.MoveNext
Next
End If
Set rs = Nothing
Set cn = Nothing
End Sub
Private Sub combobox6_Change()
Set cn = CreateObject("ADODB.Connection")
'Set cmd = CreateObject("ADODB.Command")
cn.ConnectionString = "Driver={SQL Server};server=127.0.0.1;uid=sa;pwd=;database=KIS_Sample"
cn.Open
Set rs = CreateObject("ADODB.recordset")
'strSQL1 = "select fnumber,fname from t_icitemcore where fitemid<=230 order by fnumber"
strSQL1 = "select top 200 fnumber from t_icitemcore where fnumber like '%" & ComboBox6.Value & "%'" & " order by fnumber"
'rs.Open strSQL1, cn, adOpenKeyset, adLockReadOnly
'MsgBox strSQL1
rs.Open strSQL1, cn, 1, 1
Dim i As Integer
If Not rs.EOF Then
'ComboBox6.Clear
For i = 0 To rs.RecordCount - 1
ComboBox6.AddItem rs("fnumber")
'ComboBox6.itemData(i) = rs("id").Value
rs.MoveNext
Next
End If
Set rs = Nothing
Set cn = Nothing
End Sub
Private Sub UserForm_Activate()
'初始化日期菜单
ComboBox1.List = Array(2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015)
ComboBox2.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
ComboBox3.List = Array(2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015)
ComboBox4.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
ComboBox1.ListIndex = 3
ComboBox2.ListIndex = 0
ComboBox3.ListIndex = 3
ComboBox4.ListIndex = 4
'初始化物料菜单
End Sub
Private Sub CommandButton2_Click()
'取消按钮
Unload Me
End Sub
Private Sub CommandButton1_Click()
'点击确定
'先检查日期
Dim B_date As String
Dim E_date As String
If CInt(ComboBox2.Value) < 10 Then
B_date = ComboBox1.Value & "-0" & Trim(ComboBox2.Value) & "-01"
Else
B_date = ComboBox1.Value & "-" & Trim(ComboBox2.Value) & "-01"
End If
If CInt(ComboBox4.Value) < 10 Then
E_date = ComboBox3.Value & "-0" & Trim(ComboBox4.Value) & "-01"
Else
E_date = ComboBox3.Value & "-" & Trim(ComboBox4.Value) & "-01"
End If
If CInt(ComboBox1.Value) > CInt(ComboBox3.Value) Or (CInt(ComboBox1.Value) = CInt(ComboBox3.Value) And CInt(ComboBox2.Value) > CInt(ComboBox4.Value)) Then
MsgBox ("截止日期不能小于开始日期,请重新输入")
Exit Sub
End If
If Now() >= "2011-06-01" Then
Exit Sub
End If
E_date = CStr(DateAdd("D", -1, DateAdd("M", 1, CDate(E_date))))
'MsgBox "|" & B_date & "|" & E_date & "|"
'再检查物料
Dim B_number As String
Dim E_number As String
B_number = ComboBox5.Text
E_number = ComboBox6.Text
'MsgBox "|" & B_number & "|" & E_number & "|"
Unload Me '关闭窗体'
'
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("Sheet1") '把sht指向当前工作簿的sheet1工作表
'根据日期确定表头
'整理日期
Dim B_date1 As Date
Dim E_date1 As Date
B_date1 = CDate(B_date)
E_date1 = CDate(E_date)
'MsgBox B_date1
'MsgBox E_date1
Dim i, k, m, y As Integer '计算中间跨了几个月
i = DateDiff("M", B_date1, E_date1) + 1
'MsgBox i
'清楚原来表体内容
sht.Range("A1:Z3000").Clear
'画表头
sht.Cells(1, 1) = "物料编码"
sht.Cells(1, 2) = "产品名称"
sht.Cells(1, 3) = "计量单位"
sht.Cells(1, 4) = "用量"
k = 1
Do While k <= i
sht.Cells(1, (k * 2 - 1) + 3) = CStr(year(B_date1)) & "年" & CStr(Month(B_date1)) & "月"
sht.Cells(2, (k * 2 - 1) + 3) = "数量"
sht.Cells(2, (k * 2 - 1) + 4) = "金额"
sht.Range(Chr((k * 2 - 1) + 67) & [1] & ":" & Chr((k * 2 - 1) + 68) & [1]).Merge
k = k + 1
B_date1 = DateAdd("M", 1, B_date1)
Loop
k = k - 1
'根据窗体条件计算报表数据
Set cn = CreateObject("ADODB.Connection")
Set cmd = CreateObject("ADODB.Command")
cn.ConnectionString = "Driver={SQL Server};server=127.0.0.1;uid=sa;pwd=;database=KIS_Sample"
cn.Open
Set rs = CreateObject("ADODB.recordset")
'MsgBox rs.GetRecordCount()
cmd.ActiveConnection = cn
cmd.CommandType = 4 'SqlStoredProc
cmd.CommandText = "jzc_datarpt1" '新世和物料月度销售情况统计表
'B_Date1 = "2009-11-01"
'E_Date1 = "2009-11-30"
'cmd.Parameters.Refresh
Set param = cmd.CreateParameter("@B_date", 200, 1, 10, B_date) '200代表字符型,135代表日期型,10/50代表长度
cmd.Parameters.Append param
Set param = cmd.CreateParameter("@E_date", 200, 1, 10, E_date)
cmd.Parameters.Append param
Set param = cmd.CreateParameter("@B_number", 200, 1, 50, CStr(B_number))
cmd.Parameters.Append param
Set param = cmd.CreateParameter("@E_number", 200, 1, 50, CStr(E_number))
cmd.Parameters.Append param
' rs.CursorLocation = 3
Set rs = cmd.Execute
'MsgBox rs.RecordCount
'cmd.Execute ("jzc_TGcostrpt")
'rs.Open "select * FROM xxx_costrpt", cn, 2, 2
y = 3
Do While Not rs.EOF '当数据指针未移到记录集末尾时，循环下列操作
'sht.Cells(y, 1) = i - 2 '插入序号
sht.Cells(y, 1) = RTrim(rs("fnumber")) '插入物料代码
sht.Cells(y, 2) = RTrim(rs("fname"))
sht.Cells(y, 3) = rs("funitname")
For m = 1 To i
sht.Cells(y, (m * 2 - 1) + 3) = rs("fqty" & CStr(m))
sht.Cells(y, (m * 2 - 1) + 4) = rs("famount" & CStr(m))
Next
rs.MoveNext '把指针移向下一条记录
y = y + 1 'i加1，准备把下一记录相关字段的值保存到工作表的下一行
Loop
y = y - 1
'增加合计栏
'sht.Cells(i, 2) = "合计" '插入物料代码
'改变合计行的底色
'sht.Range("A" & [i] & ":S" & [i]).Interior.ColorIndex = 6 '背景颜色
'A列左对齐
sht.Range("A3:A" & [y]).HorizontalAlignment = xlLeft
'表头合并单元格
sht.Range("A1:A2").Merge
sht.Range("B1:B2").Merge
sht.Range("C1:C2").Merge
'单元格居中
'sht.Range("A1:A2").HorizontalAlignment = xlCenter
sht.Range("A1:C2").VerticalAlignment = xlCenter
'sht.Range("B1:B2").VerticalAlignment = xlCenter
'sht.Range("C1:C2").VerticalAlignment = xlCenter
'单元格横向居中
sht.Range("D1:" & Chr((k * 2 - 1) + 68) & [2]).HorizontalAlignment = xlCenter
'将表格划线
sht.Range("A1:" & Chr((k * 2 - 1) + 68) & [y]).Borders.LineStyle = xlThin
'表中的字体要改成10号字
sht.Range("A1:" & Chr((k * 2 - 1) + 68) & [y]).Font.Size = 10
cn.Close
Set cn = Nothing
Set rs = Nothing
MsgBox "报表计算完毕 > > > > > >"
End Sub