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