The material query function developed some time ago has been optimized according to the requirements of the using department.
1. When selecting a machine tool number, a window will pop up and you can choose whether to view all materials or materials that have not yet arrived.
2. Add several columns of data to the query summary interface
3. When closing and exiting, clear the data in the data table.
4. Reflect inventory
code show as below:
1. In query summary
The three button codes are changed as follows:
Private Sub CommandButton1_Click()
Dim rng As Range
Dim rowsnum As Long
sheetexist.sheetexist
'If the "data" table is empty, call the refresh data function
' rowsnum = Worksheets("data").Range("A" & amp; Rows.Count).End(xlUp).Row
If IsEmpty(Worksheets("data").Cells(1, 1)) = True Then
CommandButton2.Value = True ' Simulate click
Application.Wait Now + TimeValue("0:00:01") ' Wait one second to ensure that the click event has been triggered
CommandButton2.Value = False 'Reset button state
End If
'
'If the "inventory" table is empty, call the refresh data function
' rowsnum = Worksheets("Inventory").Range("A1").End(xlDown).Rows.Count
If IsEmpty(Worksheets("Inventory").Cells(1, 1)) = True Then
CommandButton3.Value = True ' Simulate click
Application.Wait Now + TimeValue("0:00:01") ' Wait one second to ensure that the click event has been triggered
CommandButton3.Value = False 'Reset button state
End If
UserForm.Show
End Sub
Private Sub CommandButton2_Click()
'Refresh button, copy data
calldate.GetDataFromAnotherWorkbook
End Sub
Private Sub CommandButton3_Click()
getkc.GetDataFromSQL
End Sub
2. UserForm form
“Confirm button
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
'Clear the original data of "query summary"
Sheets("Query Summary").Select
Range("A4:D8").Value = ""
rowsnum = ActiveSheet.Range("A10").End(xlDown).Rows
If rowsnum <> 0 Then
Set rng = ActiveSheet.Range("A10:Z" & amp; rowsnum)
rng.Clear 'Clear data
rng.Borders.LineStyle = xlNone ' Remove borders
End If
ActiveWindow.FreezePanes = False 'Unfreeze window
'
'Reselect data
'JCBH = InputBox("Please enter the machine tool number, try to enter it as completely as possible, do not make fuzzy queries")
jcbh = Me.TextBox1.Value
If IsNull(jcbh) Or jcbh = "" Then
MsgBox "Machine number cannot be empty"
Exit Sub 'terminate code execution
Else
jcbh = UCase(jcbh)
End If
' ActiveSheet.CommandButton1.JCBH = Select window.TextBox1.Value
Sheets("data").Select 'Go to the "data" table
'If the filtering function is turned on, display all data
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If
'Find whether column B contains JCBH, if so, filter and copy, if not, exit
Set rng = ActiveSheet.Range("B:B").Find(jcbh)
If Not rng Is Nothing Then
'Fill in relevant data
Dim RNG1 As Range
Dim RNG2 As Range
With Worksheets("data")
Set RNG1 = .Columns("AC:AC")
Set RNG2 = .Columns("AD:AD")
JCROWS = WorksheetFunction.CountIf(.Columns("B:B"), "*" & amp; jcbh & amp; "*") 'Contains the head office of JCBH
JCROWS2 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), "/") 'Number of rows containing / , possibly a component
JCROWS3 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), ">" & amp; DateAdd("d ", -999, Date)) 'The arrival date is the number of valid dates
JCROWS4 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), ">" & amp; DateAdd("d ", -999, Date), RNG1, ">" & amp; Now() - 999) 'The delivery date is the number of valid dates
JCROWS5 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), ">" & amp; DateAdd("d ", -999, Date), RNG1, "", RNG2, ">" & amp; Now() - 999) 'When the delivery date is empty, see the actual delivery date
JCROWS6 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), "<>" & amp; "/" , .Columns("D:D"), "Machine Adding") 'Number of machine adding tasks
JCROWS7 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), "<>" & amp; "/" , .Columns("D:D"), "Purchasing") 'Purchasing task quantity
JCROWS8 = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("Z:Z"), "<>" & amp; "/" , .Columns("D:D"), "New core") 'Number of new core tasks
End With
With Sheets("Query Summary")
.Range("C5").Value = JCROWS - JCROWS2 'Total number of material items
.Range("E5").Value = JCROWS3 'Number of items that have arrived
.Range("G5").Value = JCROWS4 + JCROWS5 'Delivered
.Range("F5").Value = (JCROWS3 / (JCROWS - JCROWS2)) * 100 & amp; "%" 'Uniform rate
.Range("H5").Value = ((JCROWS4 + JCROWS5) / (JCROWS - JCROWS2)) * 100 & amp; "%" 'Delivery rate
.Range("A7").Value = JCROWS7 'Number of machining tasks
.Range("E7").Value = JCROWS8 'Number of new core tasks
.Range("G7").Value = JCROWS6 'Purchase task quantity
End With
' 'Perform data filtering
' rowsnum = Worksheets("data").Range("A1").End(xlDown).Rows 'Total number of rows
' ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=2, Criteria1:="*" & amp; JCBH & amp; "*" 'Select the 2nd column in the data range , filter value 1 is JCBH
' ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=26, Operator:=xlFilterValues, Criteria2:=Array(0, "12/31/1900")
' 'Operator:=xlFilterValues' refers to whether the filter value matches a specified set of values, and if the filter value is an array, select the 26th column in the data range
With Worksheets("data")
rowsnum = .Range("A1").End(xlDown).Rows 'Total number of rows
'
''Statistics on the number of newly purchased nuclear machines that have not yet arrived
'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$" & amp; rowsnum).AutoFilter Field:=2, Criteria1:="*" & amp; jcbh & amp; "*" 'Select the 2nd column in the data range , filter the data whose value 1 is JCBH
''Number of purchases yet to arrive
'
'ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=4, Criteria1:="Purchase"
'For Each SHOWCELL In ActiveSheet.Range("R1:R" & amp; rowsnum).SpecialCells(xlCellTypeVisible)
' If IsDate(SHOWCELL.Value) Then
' datesumcg = datesumcg + 1
'End If
'Next
datesumcg = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("D:D"), "Purchasing", .Columns("R: R"), "<2958465")
Sheets("Query Summary").Range("C7").Value = JCROWS7 - datesumcg
'ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=4
''Number of new cores yet to arrive
'
'ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=4, Criteria1:="New Core"
'For Each SHOWCELL In ActiveSheet.Range("U1:U" & amp; rowsnum).SpecialCells(xlCellTypeVisible)
' If IsDate(SHOWCELL.Value) Then
' datesumsl = datesumsl + 1
'End If
'Next
datesumsl = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("D:D"), "New Core", .Columns("U :U"), "<2958465")
Sheets("Query Summary").Range("F7").Value = JCROWS8 - datesumsl
'ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=4
''The machine adds the unreached number
'
'ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=4, Criteria1:="Machine plus"
'For Each SHOWCELL In ActiveSheet.Range("Y1:Y" & amp; rowsnum).SpecialCells(xlCellTypeVisible)
' If IsDate(SHOWCELL.Value) Then
' datesumjj = datesumjj + 1
'End If
'Next
datesumjj = WorksheetFunction.CountIfs(.Columns("B:B"), "*" & amp; jcbh & amp; "*", .Columns("D:D"), "Machine Plus", .Columns("Y :Y"), "<2958465")
Sheets("Query Summary").Range("H7").Value = JCROWS6 - datesumjj
'ActiveSheet.ShowAllData
End With
' 'Perform data filtering and radio button selection. When OptionButton1 is selected, all materials are displayed. When OptionButton2 is selected, unissued materials are displayed.
'If the filtering function is turned on, display all data
If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData
End If
If Me.OptionButton2.Value = True Then
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=2, Criteria1:="*" & amp; jcbh & amp; "*" 'Select the 2nd column in the data range, Filter value 1 is JCBH
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=26, Operator:=xlFilterValues, Criteria2:=Array(0, "12/31/1900")
Sheets("Query Summary").Range("A9").Value = "Materials not arrived:"
ElseIf Me.OptionButton1.Value = True Then
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=2, Criteria1:="*" & amp; jcbh & amp; "*" 'Select the 2nd column in the data range, Filter value 1 is JCBH
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=26, Criteria1:="<>" & amp; "/"
Sheets("Query Summary").Range("A9").Value = "All materials:"
ElseIf Me.OptionButton3.Value = True Then
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=2, Criteria1:="*" & amp; jcbh & amp; "*" 'Select the 2nd column in the data range, Filter value 1 is JCBH
ActiveSheet.Range("$A$1:$AJ$" & amp; rowsnum).AutoFilter Field:=29, Criteria1:="", Operator:=xlOr, Field:=30, Criteria1:="" '10.12 Add filtering Release undelivered materials
Sheets("Query Summary").Range("A9").Value = "Undelivered materials:" '
End If
''Select multi-region data
If rowsnum > 0 Then
Set RGE1 = ActiveSheet.Range("A1:H" & amp; rowsnum)
Set RGE2 = ActiveSheet.Range("M1:M" & amp; rowsnum)
Set RGE3 = ActiveSheet.Range("Z1:Z" & amp; rowsnum)
Set RGE4 = ActiveSheet.Range("AC1:AC" & amp; rowsnum)
Set RGE5 = ActiveSheet.Range("AF1:AF" & amp; rowsnum)
Set RGE1 = Union(RGE1, RGE2, RGE3, RGE4, RGE5) 'Merge multiple regions
RGE1.Select 'Select data area
Selection.Copy 'Copy data
Sheets("Query Summary").Select 'Go to the "Query Summary" table
Range("A10").Select 'Select cell A4
ActiveSheet.Paste 'Paste data
End If
'Get material inventory
rowsnum = 0
rowsnum = ActiveSheet.Range("A11").End(xlDown).Row
Range("M11").Select
ActiveCell.Offset(-1, 0).Value = "Real-time inventory"
' ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-7],Inventory!C[-12]:C[-7],6,FALSE),0)"
ActiveCell.FormulaR1C1 = "=IFERROR(sumif(stock!C[-12],RC[-7],stock!C[-7]),0)"
Selection.AutoFill Destination:=Range("M11:M" & amp; rowsnum), Type:=xlFillDefault
'Freeze line 11
Sheets("Query Summary").Rows("11:11").Select
ActiveWindow.FreezePanes = True
' Leave the text box blank and hide the form
Me.TextBox1.Value = ""
UserForm.Hide
Else
MsgBox "Machine number" & amp; jcbh & amp; "Does not exist" 'Prompt
Sheets("Query Summary").Select 'Return to the "Query Summary" table
Exit Sub 'terminate code execution
End If
moformat.moformat jcbh 'Format settings pass JCBH
Worksheets("data").ShowAllData 'Show all data
Sheets("Query Summary").Select 'Return to the "Query Summary" table
End Sub
Clear button
Private Sub ButtonDEL_Click()
Me.TextBox1 = ""
End Sub
“Exit” button
Private Sub ButtonEXIT_Click() Unload Me End Sub
3. Add the following code to this workbook to clear data when exiting and delete data and inventory tables.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' 'Specify the name of the worksheet to be cleared
' ThisWorkbook.Sheets("data").Cells.ClearContents
Application.DisplayAlerts = False 'Close prompt
For Each ws In ThisWorkbook.Sheets
If ws.Name = "Data" Or ws.Name = "Inventory" Then
ThisWorkbook.Sheets("data").Delete
ThisWorkbook.Sheets("Inventory").Delete
End If
Next
Application.DisplayAlerts = True 'Turn on prompts
ThisWorkbook.Save
'Close Excel
Application.Quit
'Exit the workbook
' ThisWorkbook.Close SaveChanges:=False
End Sub
4. Insert the following code into calldata to modify the data
''' is used to get data from another worksheet
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
'
''''''''''Check whether the worksheet exists, if not, create a new one
sheetexist.sheetexist
'
' ' Set the name of the worksheet to be checked
sheetname = "data"
'
' ' Traverse all worksheets in the workbook and check whether a worksheet with the same name exists
' For Each ws In ThisWorkbook.Sheets
' If ws.Name = sheetName Then
' I = 1
'End If
'Next ws
' 'If not, add it
'If I = 0 Then
' Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
' ws.Name = sheetName
'End If
'Clear original data
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 'Clear data
rng.Borders.LineStyle = xlNone ' Remove borders
End If
'Open the prompt box and perform data processing
UserForm2.Show 0
Application.ScreenUpdating = False 'Disable screen updating
Application.Interactive = False 'Prohibit user intervention in the execution of macro code
''''''''Get sales and service task information
'Set source workbook, worksheet, range
f = Dir(ThisWorkbook.Path & amp; "\2#2023After-sales Arrival and Delivery List.xlsx")
If f = "" Then
MsgBox "2# source file is not saved, please check"
Exit Sub
Else
Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & amp; "" & amp; f) 'If there is a password, Password:="?"
End If
' sourceWorkbook.Application.Visible = False ' Hide excel application
' Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & amp; "\2#2023After-sales Arrival and Delivery List.xlsx")
' Set sourceWorksheet = sourceWorkbook.Worksheets("23 years after-sales service")
For Each sourceWorksheet In sourceWorkbook.Worksheets 'The original job name may not be used after the next year, so change it to fuzzy query
If sourceWorksheet.Name Like "*years after-sales service" Then
Set sourceWorksheet = sourceWorksheet
Exit For
End If
Next sourceWorksheet
'If the source worksheet has filtering, display all data
If sourceWorksheet.FilterMode = True Then
sourceWorksheet.ShowAllData
End If
'Data source area
Set sourceRange = sourceWorksheet.Range("A3:AJ3000")
'Set target workbook, worksheet, range
Set targetWorkbook = ThisWorkbook
Set targetWorksheet = targetWorkbook.Worksheets(sheetname)
Set targetRange = targetWorksheet.Range("A1")
'Copy data
sourceRange.Copy targetRange
'Close the source workbook without saving changes
sourceWorkbook.Close SaveChanges:=False
'Hide worksheet
'Sheets("Sheet1").Visible = False
'Get the maximum value of valid cells
MAXRGN = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row
' Worksheets("data").Range("d2:d" & MAXRGN) = "Sales Service"
''''''''Get machine tool task information
'Set source workbook, worksheet, range
f = Dir(ThisWorkbook.Path & amp; "\1#2023 Arrival and Delivery List.xlsx")
If f = "" Then
MsgBox "1# source file is not saved, please check"
Exit Sub
Else
Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & amp; "" & amp; f)
End If
' sourceWorkbook.Application.Visible = False ' Hide excel application
' Set sourceWorkbook = Workbooks.Open(ThisWorkbook.Path & amp; "\1#2023arrival and delivery list.xlsx")
Set sourceWorksheet = sourceWorkbook.Worksheets("Machine Tool")
'If the source worksheet has filtering, display all data
If sourceWorksheet.FilterMode = True Then
sourceWorksheet.ShowAllData
End If
'Data source area
Set sourceRange = sourceWorksheet.Range("A3:AJ30000")
'Set target workbook, worksheet, range
Set targetWorkbook = ThisWorkbook
Set targetWorksheet = targetWorkbook.Worksheets(sheetname)
Set targetRange = targetWorksheet.Range("A" & MAXRGN + 1)
'Copy data
sourceRange.Copy targetRange
'Close the source workbook without saving changes
sourceWorkbook.Close SaveChanges:=False
Unload UserForm2
'Hide worksheet
'Sheets("data").Visible = False
'Get the maximum value of valid cells
MAXRGN2 = Worksheets(sheetname).Range("a" & Rows.Count).End(xlUp).Row
' Worksheets("data").Range(Cells(MAXRGN + 1, 4), Cells(MAXRGN2, 4)) = "Machine Tool"
''Set delivery date
'
' 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
'Set delivery date and part task type
Dim WT As Integer 'Progress bar length
UserForm1.Show 0 'Open the progress bar
WT = UserForm1.Label1.Width
UserForm1.Label1.Width = 0
UserForm1.Label1.Caption = "0%"
UserForm1.Frame1.Caption = "Data is being processed, please wait patiently..."
For i = 2 To MAXRGN2
'Set the delivery date. When the delivery date is empty, get the actual delivery date.
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
'Set the part task type, judge according to the task release date is not "/", priority machine add>new core>purchase
If Cells(i, "P").Value <> "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value <> "/" Then
Cells(i, "D").Value = "Machine plus"
ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value <> "/" Then
Cells(i, "D").Value = "Machine plus"
ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value = "/" Then
Cells(i, "D").Value = "New Core"
ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value = "/" Then
Cells(i, "D").Value = "Purchase"
ElseIf Cells(i, "P").Value = "/" And Cells(i, "S").Value <> "/" And Cells(i, "W").Value <> "/" Then
Cells(i, "D").Value = "Machine plus"
ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value <> "/" Then
Cells(i, "D").Value = "Machine plus"
ElseIf Cells(i, "P").Value <> "/" And Cells(i, "S").Value = "/" And Cells(i, "W").Value = "/" Then
Cells(i, "D").Value = "Machine plus"
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 'Close the progress bar
Application.ScreenUpdating = True 'Allow screen updating
Application.Interactive = True 'Allow users to intervene in the execution of macro code
'Application.Visible = True
'Set the first row to filter
ActiveSheet.Range("A1:AJ1").AutoFilter
'''Go to the "Query Summary" table
Sheets("Query Summary").Select
End Sub
5. Connect to SQLSERVER database to obtain inventory
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 'Define data connection object, you need to add ADO reference Microsoft ActiviteX Data Objects 2.8 Library
Dim dataset As ADODB.Recordset 'Define the recordset object, you need to add the ADO reference Microsoft ActiviteX Data Recordset Objects 2.8 Library
'
''''''''''Check whether the worksheet exists, if not, create a new one
sheetexist.sheetexist
' ' Set the name of the worksheet to be checked
sheetname = "Inventory"
' ' Traverse all worksheets in the workbook and check whether a worksheet with the same name exists
' For Each ws In ThisWorkbook.Sheets
' If ws.Name = sheetname Then
' i = 1
'End If
'Next
' 'If not, add it
'If i = 0 Then
' Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
' ws.Name = sheetname
'End If
'Clear original data
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 'Clear data
rng.Borders.LineStyle = xlNone ' Remove borders
End If
'Connect to the database and execute SQL statements
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 part code, t_icitem.fname part name, t_icitem.fmodel part specification, t_Stock.FName warehouse position, "
sqlstr = sqlstr + "t_StockPlace.fname position, convert(float,sum(icinventory.fqty )) quantity 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 "
'Execute the query and obtain the result set
Set dataset = New ADODB.Recordset
dataset.Open sqlstr, conn
'Save the result set to the worksheet
Set ws = ThisWorkbook.Worksheets(sheetname) '
'Write title to worksheet
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
'Close the recordset and connection
dataset.Close
conn.Close
'Release object
Set dataset = Nothing
Set conn = Nothing
'Set the first row to filter
ActiveSheet.Range("A1:F1").AutoFilter
'''Go to the "Query Summary" table
Sheets("Query Summary").Select
End Sub
6. moformat adjusts the format
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("Query Summary").Select
With Sheets("Query Summary")
.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 = "Task Number"
.Range("A5").Value = jcbh
.Range("C4").Value = "Total number of material items"
.Range("E4").Value = "Number of items arrived"
.Range("F4").Value = "Uniform rate"
.Range("G4").Value = "Delivered"
.Range("H4").Value = "delivery rate"
.Range("A6").Value = "Number of procurement task items"
.Range("C6").Value = "Purchasing has not arrived"
.Range("E6").Value = "Number of new core task items"
.Range("F6").Value = "The new core has not arrived yet"
.Range("G6").Value = "Number of machine adding task items"
.Range("H6").Value = "The machine has not arrived yet"
.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 = "official script"
.Range("A4:H4").Font.Size = 13
.Range("A6:H6").Interior.ColorIndex = 15
.Range("A6:H6").Font.FontStyle = "bold"
.Range("A6:H6").Font.Name = "official script"
.Range("A6:H6").Font.Size = 13
End With
'Format of material list
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
'Set line 10 to filter
rng.AutoFilter
End Sub
7. OPENFILE Some processing when opening a table
Sub Auto_Open()
MsgBox "Welcome to the task part query function!" & amp; vbCrLf & amp; _
"The first query and data refresh will be slow, please be patient."
Worksheets("Query Summary").Select
ActiveSheet.CommandButton1.BackColor = RGB(255, 69, 0)
ActiveSheet.CommandButton2.BackColor = RGB(255, 255, 0)
ActiveSheet.CommandButton3.BackColor = RGB(0, 191, 255)
'Clear the original data of "query summary"
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" & amp; rowsnum)
rng.Clear 'Clear data
rng.Borders.LineStyle = xlNone ' Remove borders
End If
ActiveWindow.FreezePanes = False 'Unfreeze the window
End Sub
8. sheetexist, used to check whether there are the same tables, if not, add a new one
Sub sheetexist()
Dim sheetname As String
Dim i As Long
Dim ws As Worksheet
i = 0
'''''''''Check whether the worksheet exists, if not, create a new one
'Set the name of the worksheet to be checked
sheetname = "data"
' Traverse all worksheets in the workbook and check whether a worksheet with the same name exists
For Each ws In ThisWorkbook.Sheets
If ws.Name = sheetname Then
i=1
End If
Next ws
'If not, add it
If i = 0 Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetname
End If
i = 0
'''''''''Check whether the worksheet exists, if not, create a new one
'Set the name of the worksheet to be checked
sheetname = "Inventory"
' Traverse all worksheets in the workbook and check whether a worksheet with the same name exists
For Each ws In ThisWorkbook.Sheets
If ws.Name = sheetname Then
i=1
End If
Next
'If not, add it
If i = 0 Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetname
End If
End Sub
