VBA 在制物料任务查询（涉及引用他表、筛选、复制、赋值、格式调整、进度条、连接SQLSERVER）

锁匙isthekey

已于 2023-10-25 11:25:02 修改

阅读量149

点赞数 1

分类专栏： EXCEL 文章标签： excel

于 2023-10-10 13:41:22 首次发布

本文链接：https://blog.csdn.net/weixin_44819434/article/details/133744472

版权

EXCEL 专栏收录该内容

19 篇文章 1 订阅

订阅专栏

按生产部门的需求，需要查询在制物料的信息，包括是否到货、齐套情况和配送情况。而这些信息都是计划部门在维护的，分别是1#在制任务的信息表和2#售服任务的信息表。
在这里插入图片描述
基本需求:
1、在查询的时候不能影响到1#表和2#表的使用
2、可以选择统计项目的全部物料和未到货物料
3、计划部门要求可以汇总出采购、顺隆（外协的）和机加任务的项数和未到货数

基本思路
当刷新数据，可以从1#表和2#表拷贝数据到“数据”表中；点击查询时，可以按要求查询相应的数据，如果“数据”表中没有数据，则关联点击刷新按钮复制数据；因为是共用的表格，退出时要清空数据不能保存。

一、基本框架
在这里插入图片描述
二、查询汇总表

这里是数据的主要展示区域，主要是两个按钮

Private Sub CommandButton1_Click()

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


  UserForm.Show
 
End Sub

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

三、thisworkbook中，主要是退出时操作

Private Sub Workbook_BeforeClose(Cancel As Boolean)
      
     ThisWorkbook.Sheets("数据").Cells.ClearContents
     ThisWorkbook.Save
   
    '关闭Excel
    Application.Quit
End Sub

四、窗体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 = Me.TextBox1.Value
If IsNull(jcbh) Or jcbh = "" Then
  MsgBox "机床编号不能为空"
  Exit Sub     '终止执行代码
  Else
  jcbh = UCase(jcbh)
End If

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("AC:AC")
        Set RNG2 = .Columns("AD:AD")

        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("Z:Z"), ">" & DateAdd("d", -999, Date), RNG1, "", RNG2, ">" & Now() - 999) '当配送日期为空时，看实际配送日期
        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("E7").Value = JCROWS7 '机加任务数量
       .Range("G7").Value = JCROWS8 '顺隆任务数量
       .Range("A7").Value = JCROWS6 '采购任务数量

   End With
rowsnum = Worksheets("数据").Range("A1").End(xlDown).Rows '总行数

'对采购顺隆机加未到数进行统计
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 & "*"
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
ActiveSheet.ShowAllData
Sheets("查询汇总").Range("C7").Value = JCROWS7 - datesumcg
'顺隆未到数
ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*"
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
ActiveSheet.ShowAllData
Sheets("查询汇总").Range("F7").Value = JCROWS8 - datesumsl
'机加未到数
ActiveSheet.Range("$A$1:$AJ$" & rowsnum).AutoFilter Field:=2, Criteria1:="*" & jcbh & "*"
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
ActiveSheet.ShowAllData
Sheets("查询汇总").Range("H7").Value = JCROWS6 - datesumjj

  
' '进行数据过滤，单选框选择，当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 = "全部物料:"
   
   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  '粘贴数据
     
      '冻结第11行
     Sheets("查询汇总").Rows("11:11").Select
     ActiveWindow.FreezePanes = True
         '将第10行设置成筛选
    ActiveSheet.Range("A10:L10").AutoFilter
     
   End If
   
' 文本框置空，并且隐藏窗体
 Me.TextBox1.Value = ""
 UserForm.Hide
    
Else
   MsgBox "机床编号" & jcbh & "不存在"  '提示
   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

五、USERFORM1
进度条
在这里插入图片描述
六、USERFORM2
提示框

七、模块calldate
用于复制1#表和2#表的数据到“数据表”


'''用于取另外工作表的数据
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 Integer
    
    
'''''''''检查工作表是否存在,不存在则新建一个
      
    ' 设置要检查的工作表名称
    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("数据").Select
     MAXRGN = Worksheets("数据").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
    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("数据")
    Set targetRange = targetWorksheet.Range("A1")
   
      
    '复制数据
    sourceRange.Copy targetRange
      
    '关闭源工作簿，并不保存更改
    sourceWorkbook.Close SaveChanges:=False
    
    '隐藏工作表
    'Sheets("Sheet1").Visible = False
    
     '取有效单元格最大值
    MAXRGN = Worksheets("数据").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

    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("数据")
    Set targetRange = targetWorksheet.Range("A" & MAXRGN + 1)
      
    '复制数据
    sourceRange.Copy targetRange
      
    '关闭源工作簿，并不保存更改
    sourceWorkbook.Close SaveChanges:=False

Unload UserForm2


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


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

UserForm1.Show 0 '打开进度条
 WT = UserForm1.Label1.Width'取进度条长度
 UserForm1.Label1.Width = 0
 UserForm1.Label1.Caption = "0%"
 UserForm1.Frame1.Caption = "数据处理中,请耐心等待......"

    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  '允许用户干预宏代码的执行
 
    '将第一行设置成筛选
    ActiveSheet.Range("A1:AJ1").AutoFilter
'''转到“查询汇总”表
    Sheets("查询汇总").Select    
End Sub

八、模块moformat
给相关数据区域设置标签和格式


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
End Sub

九、模块openfile
打开EXCEL文件时的操作


 Sub Auto_Open()

   MsgBox "欢迎使用任务零件查询功能！" & vbCrLf & _
   "第一次查询和刷新数据会较慢，请耐心等待。"
   
  
    Worksheets("查询汇总").Select
    ActiveSheet.CommandButton1.BackColor = RGB(127, 255, 0)
    ActiveSheet.CommandButton2.BackColor = RGB(255, 255, 0)
    
    '清除"查询汇总"原有数据
Dim rowsnum As Long
Dim rng As Range
Range("A4:Z7").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 '解除窗口冻结
      
  
End Sub

十、演示

物料查询

锁匙isthekey

关注

1
点赞
踩
0

收藏

觉得还不错? 一键收藏
1
评论
VBA 在制物料任务查询（涉及引用他表、筛选、复制、赋值、格式调整、进度条、连接SQLSERVER）

当刷新数据，可以从1#表和2#表拷贝数据到“数据”表中；点击查询时，可以按要求查询相应的数据，如果“数据”表中没有数据，则关联点击刷新按钮复制数据；按生产部门的需求，需要查询在制物料的信息，包括是否到货、齐套情况和配送情况。而这些信息都是计划部门在维护的，分别是1#在制任务的信息表和2#售服任务的信息表。3、计划部门要求可以汇总出采购、顺隆（外协的）和机加任务的项数和未到货数。1、在查询的时候不能影响到1#表和2#表的使用。这里是数据的主要展示区域，主要是两个按钮。用于复制1#表和2#表的数据到“数据表”
复制链接

扫一扫