VBA 物料信息查询的优化（涉及引用他表、筛选、复制、赋值、格式调整、进度条、连接SQLSERVER）

针对前段时间做的物料查询功能，根据使用部门的要求进行优化。
1、在选择机床编号时，跳出窗体，进行选择是查看全部物料还是未到货物料
2、在查询汇总界面增加几列数据
3、关闭退出时，清空数据表中的数据。
4、体现库存

代码如下：
1、在查询汇总中

三个按钮代码更改如下：

Private Sub CommandButton1_Click()

   Dim rng As Range
   Dim rowsnum As Long
   
    sheetexist.sheetexist
'如果“数据”表为空，则调用刷新数据功能
'    rowsnum = Worksheets("数据").Range("A" & Rows.Count).End(xlUp).Row
    If IsEmpty(Worksheets("数据").Cells(1, 1)) = True Then
        CommandButton2.Value = True ' 模拟点击
        Application.Wait Now + TimeValue("0:00:01") ' 等待一秒钟，以确保点击事件已经被触发
        CommandButton2.Value = False ' 重置按钮状态
    End If
'
 
'如果“库存”表为空，则调用刷新数据功能
'    rowsnum = Worksheets("库存").Range("A1").End(xlDown).Rows.Count
    If IsEmpty(Worksheets("库存").Cells(1, 1)) = True Then
        CommandButton3.Value = True ' 模拟点击
        Application.Wait Now + TimeValue("0:00:01") ' 等待一秒钟，以确保点击事件已经被触发
        CommandButton3.Value = False ' 重置按钮状态
    End If


  UserForm.Show
 
End Sub

Private Sub CommandButton2_Click()
'刷新按钮，复制数据
  calldate.GetDataFromAnotherWorkbook
End Sub

Private Sub CommandButton3_Click()
  getkc.GetDataFromSQL
End Sub

2、UserForm窗体
“确定”按钮

Private Sub ButtonOK_Click()
   

Dim rng As Range
Dim RGE1 As Range
Dim RGE2 As Range
Dim RGE3 As Range
Dim RGE4 As Range
Dim RGE5 As Range
Dim jcbh As String
Dim rowsnum As Long
Dim JCROWS As Long
Dim JCROWS2 As Long
Dim JCROWS3 As Long
Dim JCROWS4 As Long
Dim JCROWS5 As Long
Dim JCROWS6 As Long
Dim JCROWS7 As Long
Dim JCROWS8 As Long
Dim visibleCells As Range



'清除"查询汇总"原有数据
Sheets("查询汇总").Select
Range("A4:D8").Value = ""
rowsnum = ActiveSheet.Range("A10").End(xlDown).Rows
If rowsnum <> 0 Then
  Set rng = ActiveSheet.Range("A10:Z" & rowsnum)
  rng.Clear ' 清除数据
  rng.Borders.LineStyle = xlNone  ' 移除边框
End If

    ActiveWindow.FreezePanes = False '解除窗口冻结
'

'重新选择数据
'JCBH = InputBox("请录入机床编号，尽量完整录入，不要模糊查询")
 jcbh = Me.TextBox1.Value
If IsNull(jcbh) Or jcbh = "" Then
  MsgBox "机床编号不能为空"
  Exit Sub     '终止执行代码
  Else
  jcbh = UCase(jcbh)
End If


  

 
'   ActiveSheet.CommandButton1.JCBH = 选择窗口.TextBox1.Value


Sheets("数据").Select '转到"数据"表
'如果筛选功能打开，则显示所有数据
  If ActiveSheet.FilterMode = True Then
     ActiveSheet.ShowAllData
  End If


'查找B列是否包含JCBH，如果有则过滤复制，没有则退出
Set rng = ActiveSheet.Range("B:B").Find(jcbh)

If Not rng Is Nothing Then

   '填充相关数据
        Dim RNG1 As Range
        Dim RNG2 As Range
   With Worksheets("数据")
'        Set RNG1 = .Columns("AD:AD")
'        Set RNG2 = .Columns("AE:AE")
'240510改成只看“配送单提供日期”
         Set RNG1 = .Columns("AC:AC")
   
   
   
 
        JCROWS = WorksheetFunction.CountIf(.Columns("B:B"), "*" & jcbh & "*") '包含JCBH的总行
        JCROWS2 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), "/") '包含/的行数，有可能是组部件
        JCROWS3 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), ">" & DateAdd("d", -999, Date))   '到货日期是有效日期的数量
        JCROWS4 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), ">" & DateAdd("d", -999, Date), RNG1, ">" & Now() - 999) '配送日期是有效日期的数量
'        JCROWS5 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("AA:AA"), ">" & DateAdd("d", -999, Date), RNG1, "", RNG2, ">" & Now() - 999) '当配送日期为空时，看实际配送日期
        JCROWS5 = 0
        JCROWS6 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), "<>" & "/", .Columns("D:D"), "机加") '机加任务数量
        JCROWS7 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), "<>" & "/", .Columns("D:D"), "采购") '采购任务数量
        JCROWS8 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("Z:Z"), "<>" & "/", .Columns("D:D"), "新核") '新核任务数量
        
     
   End With
   With Sheets("查询汇总")
       .Range("C5").Value = JCROWS - JCROWS2 '物料总项数
       .Range("E5").Value = JCROWS3 '已到货项数
       .Range("G5").Value = JCROWS4 + JCROWS5 '已配送
       .Range("F5").Value = (JCROWS3 / (JCROWS - JCROWS2)) * 100 & "%" '齐套率
       .Range("H5").Value = ((JCROWS4 + JCROWS5) / (JCROWS - JCROWS2)) * 100 & "%" '配送率
       .Range("A7").Value = JCROWS7 '机加任务数量
       .Range("E7").Value = JCROWS8 '新核任务数量
       .Range("G7").Value = JCROWS6 '采购任务数量

   End With




' '进行数据过滤
'   rowsnum = Worksheets("数据").Range("A1").End(xlDown).Rows '总行数
'   ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & JCBH & "*" '选中数据范围内第2列，过滤值1为JCBH
'   ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=26, Operator:=xlFilterValues, Criteria2:=Array(0, "12/31/1900")
'   '“Operator:=xlFilterValues”指的用于筛选值是否匹配一组指定的值,并且过滤值要是数组 ，选中数据范围内第26列

With Worksheets("数据")
    rowsnum = .Range("A1").End(xlDown).Row '总行数
    '
    ''对采购新核机加未到数进行统计
    'Dim SHOWCELL As Range
    'Dim LJTYPE As Range
    'Dim datesumcg As Long
    'Dim datesumsl As Long
    'Dim datesumjj As Long
    '
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*" '选中数据范围内第2列，过滤值1为JCBH的数据
    ''采购未到数
    '
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=4, Criteria1:="采购"
    'For Each SHOWCELL In ActiveSheet.Range("R1:R" & rowsnum).SpecialCells(xlCellTypeVisible)
    ' If IsDate(SHOWCELL.Value) Then
    '    datesumcg = datesumcg + 1
    ' End If
    'Next
    datesumcg = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("D:D"), "采购", .Columns("R:R"), "<2958465")
     Sheets("查询汇总").Range("C7").Value = JCROWS7 - datesumcg
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=4
      
    
    
    
    ''新核未到数
    '
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=4, Criteria1:="新核"
    'For Each SHOWCELL In ActiveSheet.Range("U1:U" & rowsnum).SpecialCells(xlCellTypeVisible)
    ' If IsDate(SHOWCELL.Value) Then
    '    datesumsl = datesumsl + 1
    ' End If
    'Next
    datesumsl = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("D:D"), "新核", .Columns("U:U"), "<2958465")
    Sheets("查询汇总").Range("F7").Value = JCROWS8 - datesumsl
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=4
    ''机加未到数
    '
    'ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=4, Criteria1:="机加"
    'For Each SHOWCELL In ActiveSheet.Range("Y1:Y" & rowsnum).SpecialCells(xlCellTypeVisible)
    ' If IsDate(SHOWCELL.Value) Then
    '    datesumjj = datesumjj + 1
    ' End If
    'Next
    datesumjj = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & jcbh & "*", .Columns("D:D"), "机加", .Columns("Y:Y"), "<2958465")
    Sheets("查询汇总").Range("H7").Value = JCROWS6 - datesumjj
    'ActiveSheet.ShowAllData

  End With
   
' '进行数据过滤，单选框选择，当OptionButton1选中时显示全部物料，当OptionButton2选中时显示未发物料
'如果筛选功能打开，则显示所有数据
  If ActiveSheet.FilterMode = True Then
     ActiveSheet.ShowAllData
  End If

   If Me.OptionButton2.Value = True Then
        ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*" '选中数据范围内第2列，过滤值1为JCBH
        ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=26, Operator:=xlFilterValues, Criteria2:=Array(0, "12/31/1900")
        Sheets("查询汇总").Range("A9").Value = "未到物料:"
   ElseIf Me.OptionButton1.Value = True Then
       ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*"    '选中数据范围内第2列，过滤值1为JCBH
       ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=26, Criteria1:="<>" & "/"
       Sheets("查询汇总").Range("A9").Value = "全部物料:"
    ElseIf Me.OptionButton3.Value = True Then
       ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*"    '选中数据范围内第2列，过滤值1为JCBH
       ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=29, Criteria1:="", Operator:=xlOr, Field:=30, Criteria1:=""  '10.12增加过滤出未配送的物料
       Sheets("查询汇总").Range("A9").Value = "未配送物料:"  '
   
   
   End If
   
''选择多区域数据
   

   If rowsnum > 0 Then
     Set RGE1 = ActiveSheet.Range("A1:H" & rowsnum)
     Set RGE2 = ActiveSheet.Range("M1:M" & rowsnum)
     Set RGE3 = ActiveSheet.Range("Z1:Z" & rowsnum)
     Set RGE4 = ActiveSheet.Range("AC1:AC" & rowsnum)
     Set RGE5 = ActiveSheet.Range("AF1:AF" & rowsnum)
     
     Set RGE1 = Union(RGE1, RGE2, RGE3, RGE4, RGE5)  '合并多区域
     RGE1.Select  '选择数据区域
     
     Selection.Copy '复制数据
     Sheets("查询汇总").Select '转到“查询汇总”表
     Range("A10").Select  '选择A4单元格
     ActiveSheet.Paste  '粘贴数据
     
   End If
   
   '取物料库存
    rowsnum = 0
    rowsnum = ActiveSheet.Range("A11").End(xlDown).Row
    Range("M11").Select
    ActiveCell.Offset(-1, 0).Value = "即时库存"
'    ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-7],库存!C[-12]:C[-7],6,FALSE),0)"
    ActiveCell.FormulaR1C1 = "=IFERROR(sumif(库存!C[-12],RC[-7],库存!C[-7]),0)"
    Selection.AutoFill Destination:=Range("M11:M" & rowsnum), Type:=xlFillDefault
    
      '冻结第11行
     Sheets("查询汇总").Rows("11:11").Select
     ActiveWindow.FreezePanes = True

   
' 文本框置空，并且隐藏窗体
 Me.TextBox1.Value = ""
 UserForm.Hide
    
Else
   MsgBox "机床编号" & jcbh & "不存在"  '提示
   Sheets("查询汇总").Select  '转回"查询汇总"表
   Exit Sub     '终止执行代码
End If
 
 
moformat.moformat jcbh '格式设置传递JCBH

Worksheets("数据").ShowAllData '显示所有数据
Sheets("查询汇总").Select  '转回"查询汇总"表
   
End Sub

“清除”按钮

Private Sub ButtonDEL_Click()
       Me.TextBox1 = ""
End Sub

“退出”按钮

Private Sub ButtonEXIT_Click()
  Unload Me
End Sub

3、在thisworkbook中增加如下代码，用于退出时清除数据，并删除数据和库存表格

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'    '指定要清空的工作表名称
'     ThisWorkbook.Sheets("数据").Cells.ClearContents

    
    Application.DisplayAlerts = False '关闭提示
    For Each ws In ThisWorkbook.Sheets
       If ws.Name = "数据" Or ws.Name = "库存" Then
       ThisWorkbook.Sheets("数据").Delete
       ThisWorkbook.Sheets("库存").Delete
       End If
    Next
   
    Application.DisplayAlerts = True '开启提示
     
     
     
     
     ThisWorkbook.Save
      
    '关闭Excel
    Application.Quit
    '退出工作簿
'    ThisWorkbook.Close SaveChanges:=False
End Sub

4、在calldata中插入如下代码，用于修改数据

'''用于取另外工作表的数据
Sub GetDataFromAnotherWorkbook()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim MAXRGN As Long
    Dim MAXRGN2 As Long
    Dim sheetname As String
    Dim ws As Worksheet
    Dim i As long
    
'
''''''''''检查工作表是否存在,不存在则新建一个
  sheetexist.sheetexist
'
'    ' 设置要检查的工作表名称
    sheetname = "数据"
'
'    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
'    For Each ws In ThisWorkbook.Sheets
'        If ws.Name = sheetName Then
'         I = 1
'        End If
'    Next ws
'    '如果没有则新增
'    If I = 0 Then
'      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'      ws.Name = sheetName
'    End If


    '清除原有数据
    ActiveWorkbook.Sheets(sheetname).Select
     MAXRGN = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row
    If MAXRGN <> 0 Then
      Set rng = ActiveSheet.Range("A1:AZ" & MAXRGN)
      rng.Clear ' 清除数据
      rng.Borders.LineStyle = xlNone  ' 移除边框
    End If
    
'打开提示框，进行数据处理


UserForm2.Show 0
Application.ScreenUpdating = False '禁止屏幕更新
Application.Interactive = False  '禁止用户干预宏代码的执行
    
''''''''取售服任务信息

    '设置源工作簿、工作表、范围
    f = Dir(ThisWorkbook.Path & "\2#2023售后到货及配送清单.xlsx")
    If f = "" Then
        MsgBox "2#源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "\" & f) '如果设有密码加, Password:="？？？"
    End If
'    sourceWorkbook.Application.Visible = False ' 隐藏excel应用
'    Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "\2#2023售后到货及配送清单.xlsx")
'    Set sourceWorksheet = sourceWorkbook.Worksheets("23年售后")
    For Each sourceWorksheet In sourceWorkbook.Worksheets  '换成下一年后原来工作名称可能用不了，改成模糊查询
       If sourceWorksheet.Name Like "*年售后" Then
        Set sourceWorksheet = sourceWorksheet
        Exit For
       End If
    Next sourceWorksheet

    '    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '数据源区域
    Set sourceRange = sourceWorksheet.Range("A3:AJ3000")
      
    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = targetWorkbook.Worksheets(sheetname)
    Set targetRange = targetWorksheet.Range("A1")
   
      
    '复制数据
    sourceRange.Copy targetRange
      
    '关闭源工作簿，并不保存更改
    sourceWorkbook.Close SaveChanges:=False
    
    '隐藏工作表
    'Sheets("Sheet1").Visible = False
    
     '取有效单元格最大值
    MAXRGN = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row
'     Worksheets("数据").Range("d2:d" & MAXRGN) = "售服"
    
  ''''''''取机床任务信息
    '设置源工作簿、工作表、范围
     f = Dir(ThisWorkbook.Path & "\1#2023到货及配送清单.xlsx")
    If f = "" Then
        MsgBox "1#源文件不存，请查看"
        Exit Sub
    Else
        Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "\" & f)
    End If
'     sourceWorkbook.Application.Visible = False ' 隐藏excel应用
'    Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "\1#2023到货及配送清单.xlsx")
    Set sourceWorksheet = sourceWorkbook.Worksheets("机床")
    
'    如果源工作表有过滤，则显示所有数据
    If sourceWorksheet.FilterMode = True Then
     sourceWorksheet.ShowAllData
    End If
    '数据源区域
    Set sourceRange = sourceWorksheet.Range("A3:AJ30000")
      
    '设置目标工作簿、工作表、范围
    Set targetWorkbook = ThisWorkbook
    Set targetWorksheet = targetWorkbook.Worksheets(sheetname)
    Set targetRange = targetWorksheet.Range("A" & MAXRGN + 1)
      
    '复制数据
    sourceRange.Copy targetRange
      
    '关闭源工作簿，并不保存更改
    sourceWorkbook.Close SaveChanges:=False

Unload UserForm2
    '隐藏工作表
'    Sheets("数据").Visible = False

     '取有效单元格最大值
     MAXRGN2 = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row

'    Worksheets("数据").Range(Cells(MAXRGN + 1, 4), Cells(MAXRGN2, 4)) = "机床"
    
    
''设置配送日期
'
'    For i = 1 To MAXRGN2
'     If (Cells(i, "AC").Value = "" Or IsNull(Cells(i, "AC").Value)) And Cells(i, "AD").Value <> "" Then
'        Cells(i, "AC").Value = Cells(i, "AD").Value
'     End If
'
'    Next i


'设置配送日期以及零件任务类型
Dim WT As Integer '进度条长度

UserForm1.Show 0 '打开进度条
 WT = UserForm1.Label1.Width
 UserForm1.Label1.Width = 0
 UserForm1.Label1.Caption = "0%"
 UserForm1.Frame1.Caption = "数据处理中,请耐心等待......"
 on error resume next  '源数据有时维护会出错，会提示格式不对，所以有错时跳过错误
    For i = 2 To MAXRGN2
    '设置配送日期，当配送日期为空时，取实际配送日期
    
     If (Cells(i, "AC").Value = "" Or IsNull(Cells(i, "AC").Value)) And Cells(i, "AD").Value <> "" Then
        Cells(i, "AC").Value = Cells(i, "AD").Value
     End If
     '设置零件任务类型，按任务下达日期不为"/"来判断，优先权机加>新核>采购
     If Cells(i, "P").Value <> "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value <> "/" Then
        Cells(i, "D").Value = "机加"
     ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value <> "/" Then
        Cells(i, "D").Value = "机加"
     ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value = "/" Then
        Cells(i, "D").Value = "新核"
     ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value = "/" Then
        Cells(i, "D").Value = "采购"
     ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value <> "/" Then
        Cells(i, "D").Value = "机加"
     ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value <> "/" Then
        Cells(i, "D").Value = "机加"
     ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value = "/" Then
        Cells(i, "D").Value = "机加"
     Else
        Cells(i, "D").Value = ""
     End If
     
     
     UserForm1.Label1.Width = (i / MAXRGN2) * WT
     UserForm1.Label1.Caption = Format(i / MAXRGN2, "0.0%")
     DoEvents
    Next i
        
Unload UserForm1 '关闭进度条
Application.ScreenUpdating = True '允许屏幕更新
Application.Interactive = True  '允许用户干预宏代码的执行
'Application.Visible = True
    
    
    '将第一行设置成筛选
    ActiveSheet.Range("A1:AJ1").AutoFilter
'''转到“查询汇总”表
    Sheets("查询汇总").Select
    
    
End Sub


        

5、连接SQLSERVER数据库获取库存

 Sub GetDataFromSQL()

    Dim sqlstr As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim sheetname As String
    Dim i As Long, MAXRGN As Long
    Dim conn As ADODB.Connection  '定义数据连接对象 ，需要添加ADO引用Microsoft ActiviteX Data Objects 2.8 Library
    Dim dataset As ADODB.Recordset  '定义记录集对象，需要添加ADO引用Microsoft ActiviteX Data Recordset Objects 2.8 Library
    

'
''''''''''检查工作表是否存在,不存在则新建一个
  sheetexist.sheetexist
'    ' 设置要检查的工作表名称
    sheetname = "库存"
'    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
'    For Each ws In ThisWorkbook.Sheets
'     If ws.Name = sheetname Then
'        i = 1
'     End If
'    Next
'    '如果没有则新增
'    If i = 0 Then
'      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'      ws.Name = sheetname
'    End If
    '清除原有数据
    ActiveWorkbook.Sheets(sheetname).Select
     MAXRGN = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row
    If MAXRGN <> 0 Then
      Set rng = ActiveSheet.Range("A1:AZ" & MAXRGN)
      rng.Clear ' 清除数据
      rng.Borders.LineStyle = xlNone  ' 移除边框
    End If
    

    '连接数据库并执行SQL语句
    Set conn = New ADODB.Connection
    conn.ConnectionString = "Provider=SQLOLEDB;Data Source=192.168.100.3;Initial Catalog=AIS20150813141843;User ID=sa;Password=Chr_2016"
    conn.Open
    
    sqlstr = sqlstr + "SELECT  t_icitem.fnumber 零件代码, t_icitem.fname 零件名称, t_icitem.fmodel 零件规格, t_Stock.FName 仓位, "
    sqlstr = sqlstr + "t_StockPlace.fname 仓位, convert(float,sum(icinventory.fqty )) 数量 FROM icinventory  "
    sqlstr = sqlstr + "inner join  t_icitem   on ( icinventory.fitemid = t_icitem.fitemid )  and  t_icitem.fnumber not like '3.10.%'   "
    sqlstr = sqlstr + "inner join t_item a on t_icitem.FItemID=a.FItemID "
    sqlstr = sqlstr + "inner join t_Stock  on icinventory.FStockID=t_Stock.FItemID "
    sqlstr = sqlstr + "inner join t_StockPlace on icinventory.FStockPlaceID=t_StockPlace.FSPID "
    sqlstr = sqlstr + "WHERE 1=1 and icinventory.fqty<>0 group by t_icitem.fitemid,  t_icitem.fnumber,t_icitem.fname,  "
    sqlstr = sqlstr + "t_icitem.fmodel,   t_Stock.FName,t_StockPlace.fname order by t_icitem.fnumber "

        '执行查询并获取结果集
    Set dataset = New ADODB.Recordset
    dataset.Open sqlstr, conn
      
  
      
    '将结果集保存到工作表
    Set ws = ThisWorkbook.Worksheets(sheetname) '
    '将标题写入工作表
     For i = 0 To dataset.Fields.Count - 1
        ws.Cells(1, i + 1).Value = dataset.Fields(i).Name
     Next i
    ActiveSheet.Range("A2").CopyFromRecordset dataset
    '关闭记录集和连接
    dataset.Close
    conn.Close
      
    '释放对象
    Set dataset = Nothing
    Set conn = Nothing
    
     '将第一行设置成筛选
    ActiveSheet.Range("A1:F1").AutoFilter
    
 '''转到“查询汇总”表
    Sheets("查询汇总").Select
    




End Sub

6、moformat 调整格式

Option Explicit

Sub moformat(ByVal jcbh As String)
    Dim rng As Range
    Dim lastrow As Long
    Dim lastcol As Long
    Dim STR As Variant
     
    Worksheets("查询汇总").Select
    
   With Sheets("查询汇总")
       .Range("A4:B4").Merge
       .Range("A5:B5").Merge
       .Range("A6:B6").Merge
       .Range("A7:B7").Merge
       .Range("C4:D4").Merge
       .Range("C5:D5").Merge
       .Range("C6:D6").Merge
       .Range("C7:D7").Merge
       .Range("A4").Value = "任务编号"
       .Range("A5").Value = jcbh
       .Range("C4").Value = "物料总项数"
       .Range("E4").Value = "已到货项数"
       .Range("F4").Value = "齐套率"
       .Range("G4").Value = "已配送"
       .Range("H4").Value = "配送率"
       .Range("A6").Value = "采购任务项数"
       .Range("C6").Value = "采购未到"
       .Range("E6").Value = "新核任务项数"
       .Range("F6").Value = "新核未到"
       .Range("G6").Value = "机加任务项数"
       .Range("H6").Value = "机加未到"
       .Range("A4:H7").Font.Size = 11
       .Range("A4:L7").Borders.LineStyle = True
       .Range("A4:H4").Interior.ColorIndex = 15
       .Range("A4:H4").Font.FontStyle = "bold"
       .Range("A4:H4").Font.Name = "隶书"
       .Range("A4:H4").Font.Size = 13
       .Range("A6:H6").Interior.ColorIndex = 15
       .Range("A6:H6").Font.FontStyle = "bold"
       .Range("A6:H6").Font.Name = "隶书"
       .Range("A6:H6").Font.Size = 13
   End With
    
    
    '物料列表的格式
    STR = ActiveSheet.Range("A11").Value
    If STR <> "" Then
        With ActiveSheet
            lastrow = .Range("A10").End(xlDown).Row
            lastcol = .Range("A10").End(xlToRight).Column
        End With
        
        Set rng = ActiveSheet.Range(Cells(10, 1), Cells(lastrow, lastcol))
        rng.Borders.LineStyle = True
        
        Set rng = ActiveSheet.Range(Cells(10, 1), Cells(10, lastcol))
        With rng
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Size = 11
            .Font.Bold = True
            .Interior.ColorIndex = 15
            .WrapText = True
        End With
    Else
        Exit Sub
    End If

    '将第10行设置成筛选
    rng.AutoFilter

End Sub

7、OPENFILE 打开表格时的一些处理

 Sub Auto_Open()

   MsgBox "欢迎使用任务零件查询功能！" & vbCrLf & _
   "第一次查询和刷新数据会较慢，请耐心等待。"
   
  
    Worksheets("查询汇总").Select
    ActiveSheet.CommandButton1.BackColor = RGB(255, 69, 0)
    ActiveSheet.CommandButton2.BackColor = RGB(255, 255, 0)
    ActiveSheet.CommandButton3.BackColor = RGB(0, 191, 255)
    
    '清除"查询汇总"原有数据
Dim rowsnum As Long
Dim rng As Range
Range("A4:Z7").Value = ""
rowsnum = ActiveSheet.Range("A10").End(xlDown).Row
If rowsnum <> 0 Then
  Set rng = ActiveSheet.Range("A10:Z" & rowsnum)
  rng.Clear ' 清除数据
  rng.Borders.LineStyle = xlNone  ' 移除边框
End If

    ActiveWindow.FreezePanes = False '解除窗口冻结
      
  
End Sub

8、sheetexist，用于检查是否有相同表格，没有则新增

Sub sheetexist()
Dim sheetname As String
Dim i As Long
Dim ws As Worksheet

 i = 0
    
'''''''''检查工作表是否存在,不存在则新建一个
      
    ' 设置要检查的工作表名称
    sheetname = "数据"
      
    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sheetname Then
         i = 1
        End If
    Next ws
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = sheetname
    End If

 i = 0

'''''''''检查工作表是否存在,不存在则新建一个
      
    ' 设置要检查的工作表名称
    sheetname = "库存"
    ' 遍历工作簿中的所有工作表，检查是否存在同名工作表
    For Each ws In ThisWorkbook.Sheets
     If ws.Name = sheetname Then
        i = 1
     End If
    Next
    '如果没有则新增
    If i = 0 Then
      Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      ws.Name = sheetname
    End If


End Sub