麻辣家族討論版版 - Powered by Discuz! Board

標題: 用VBA做查詢系統 [打印本頁]

作者: aassddff736 時間: 2024-3-3 15:57 標題: 用VBA做查詢系統

請教各位前輩

我有一個儲位表單,六個鋼板工作表資料
想要在建立主頁做查詢系統:查鋼板資料,放置儲位,還有哪些空儲位 ,尚未建立儲位的鋼板
[attach]37537[/attach]
鋼板資料常常會新增及刪除項目
儲位也常常會變換放置的鋼板

作者: aassddff736 時間: 2024-3-3 16:14

回復 1# aassddff736
更正有7個鋼板工作表

作者: Andy2483 時間: 2024-3-4 09:36

本帖最後由 Andy2483 於 2024-3-4 10:18 編輯

回復 2# aassddff736

謝謝前輩發表此主題與範例
建議刪除範例檔裡的多餘空欄空列,學習方案如下,請前輩參考

Option Explicit
Sub 刪除多餘空欄空列()
Dim s As Worksheet, i&, j%, R&, C%
'↑宣告變數:&是長整數,%是短整數
For Each s In Worksheets
'↑設逐項迴圈!令S變數是活頁簿裡的工作表
Application.Goto s.[A1]: R = 0: C = 0
'↑令游標跳到迴圈工作表的A1儲存格,令R變數歸零,令C變數歸零
With Range(s.[A1], s.UsedRange)
'↑以下是關於A1儲存格到有使用儲存格這範圍儲存格的程序
   For j = 1 To .Cells.Columns.Count
   '↑設順迴圈!令j從1 到該範圍的欄數
      If R < Cells(Rows.Count, j).End(xlUp).Row Then R = Cells(Rows.Count, j).End(xlUp).Row
      '↑如果R變數小於迴圈欄最後有內容儲存格的列號,就令R變數是該列號數
   Next
   If .Rows.Count > R + 1 Then Rows(R + 1 & ":" & .Rows.Count).Delete
   '↑如果範圍列數大於 R變數+1!就令多餘的列刪除
   For i = 1 To .Cells.Rows.Count
   '↑設順迴圈!令i從1 到該範圍的列數
      If C < Cells(i, Columns.Count).End(xlToLeft).Column Then C = Cells(i, Columns.Count).End(xlToLeft).Column
      '↑如果C變數小於迴圈列最後有內容儲存格的欄號,就令C變數是該欄號數
   Next
   If .Columns.Count > C + 1 Then Range(Cells(1, C + 1), Cells(1, .Columns.Count)).EntireColumn.Delete
   '↑如果範圍欄數大於 C變數+1!就令多餘的欄刪除
End With
Next
End Sub

試執行後另存新檔

作者: aassddff736 時間: 2024-3-4 13:34

回復 3# Andy2483

謝謝您，非常感謝

作者: aassddff736 時間: 2024-3-6 22:19

回復 3# Andy2483

我另存好了
[attach]37567[/attach]

作者: Andy2483 時間: 2024-3-7 09:59

回復 5# aassddff736

鋼板編號有重複,需手動排除重複後才顯示彙整資料:
[attach]37569[/attach]

Option Explicit
Sub 資料彙整入主頁篩選區()
Dim Brr, Crr, Z, Q, i&, j%, R&, N&, S, T$, E&, TT$
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("主頁")
.Activate
If .AutoFilter Is Nothing Then [B17:P17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow
   .FreezePanes = False
   .ScrollRow = 13
   .SplitRow = 5
   .FreezePanes = True
End With
.UsedRange.Offset(17).EntireRow.Delete
.[B:D].NumberFormat = "@"
.[B:D].Font.Bold = True
End With
ReDim Crr(1 To 10000, 1 To 15)
Q = Array(Range([儲位!B3], [儲位!A65536].End(xlUp)), Range([儲位!E3], [儲位!D65536].End(xlUp)))
For Each Brr In Q
Brr = Brr
For i = 1 To UBound(Brr)
   N = N + 1: T = Brr(i, 2): Crr(N, 1) = Brr(i, 1): Crr(N, 2) = T: Z(T) = N
Next
Next
E = N: Q = Array("1至588", "SUPER", "POWER", "POWER試產", "TEST", "待報廢", "報廢")
For Each S In Q
Brr = Sheets(S).[A1].CurrentRegion
For i = 3 To UBound(Brr)
   R = Z(Brr(i, 1))
   If Z.Exists(Brr(i, 2) & "|") Then TT = TT & " / " & S & "表_" & Brr(i, 2) Else Z(Brr(i, 2) & "|") = "A"
   If R = 0 Then N = N + 1: R = N
   For j = 1 To 14: Crr(R, j + 1) = Brr(i, j): Next
   If R > E Then Crr(R, 1) = S
Next
Next
If N = 0 Then Exit Sub
If TT <> "" Then MsgBox "鋼板編號 " & Mid(TT, 4) & " 重複": Exit Sub
With [B18].Resize(N, 15): .Value = Crr: .Borders.LineStyle = 1: End With
End Sub

Sub 清除主頁篩選區資料()
With Sheets("主頁")
.Activate
If .AutoFilter Is Nothing Then [B17:P17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow: .FreezePanes = False: .ScrollRow = 1: .SplitRow = 17: .FreezePanes = True: End With
.UsedRange.Offset(17).EntireRow.Delete
End With
End Sub

作者: aassddff736 時間: 2024-3-7 13:23

回復 6# Andy2483

應為鋼板毀損所以開新的會有重複鋼板號情況,可以依前面活頁為優先嗎?基本報廢區不會編儲位號碼,但是會查資料

作者: Andy2483 時間: 2024-3-7 13:54

回復 Andy2483

應為鋼板毀損所以開新的會有重複鋼板號情況,可以依前面活頁為優先嗎?基本報廢區不會 ...
aassddff736 發表於 2024-3-7 13:23

照理說同鋼板編號財產編號要相同,下圖所示產編號不同何因?
[attach]37571[/attach]

If TT <> "" Then MsgBox "鋼板編號 " & Mid(TT, 4) & " 重複" : Exit Sub
改為
If TT <> "" Then MsgBox "鋼板編號 " & Mid(TT, 4) & " 重複" ': Exit Sub

作者: aassddff736 時間: 2024-3-7 14:03

回復 6# Andy2483

謝謝您的幫忙
[attach]37570[/attach]

B欄"存放區域",如果鋼板沒有建立儲位編號我想留白,但是報廢與帶報廢鋼板顯示
然後就是我要怎麼查空儲位

作者: aassddff736 時間: 2024-3-7 14:05

回復 8# Andy2483

新開一個一樣鋼板材編會不同報帳問題

作者: aassddff736 時間: 2024-3-7 14:11

回復 9# aassddff736

抱歉! 忘了說我想要工作表原格式在主頁上可以嗎? 那些儲存格色彩是標記用的

作者: Andy2483 時間: 2024-3-7 14:18

回復 9# aassddff736

1.如果鋼板沒有建立儲位編號 B欄留白,但是報廢與帶報廢鋼板B欄顯示
If R > E Then Crr(R, 1) = S
改為
If R > E And InStr("待報廢", S) Then Crr(R, 1) = S

2.怎麼查空儲位?
手動篩選D欄 > 空格

作者: aassddff736 時間: 2024-3-7 14:22

回復 12# Andy2483

也是直接篩選比較快

作者: Andy2483 時間: 2024-3-7 14:32

回復 11# aassddff736

如果全部格式都要過去,請先自己試著錄製巨集,接龍到主頁表
發話題的範例應該要含格式都複製過去讓協助者明白需求

作者: Andy2483 時間: 2024-3-7 14:34

回復 Andy2483

也是直接篩選比較快
aassddff736 發表於 2024-3-7 14:22

資料如果有匯到主頁,篩選的動作代碼錄製巨集就可以辦到

作者: aassddff736 時間: 2024-3-7 14:42

回復 15# Andy2483

感謝您我再試試看

作者: Andy2483 時間: 2024-3-8 08:40

回復 11# aassddff736
謝謝論壇,謝謝各位前輩
[attach]37574[/attach]

Option Explicit
Sub 資料彙整入主頁篩選區()
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim Arr, Brr, Crr(1 To 10000, 1 To 1), Z, Q, i&, j%, R&, N&, S, T$, E&, TT$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("主頁")
.Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
Q = Array("1至588", "SUPER", "POWER", "POWER試產", "TEST", "待報廢", "報廢")
For Each S In Q
Set xR = [D65536].End(3)(2, 0): If Sheets(S).FilterMode = True Then Sheets(S).ShowAllData
R = Sheets(S).[B65536].End(3).Row - 2: Sheets(S).[A3].Resize(R, 14).Copy xR: If InStr("待報廢", S) Then xR.Resize(R, 1).Offset(, -1) = S
Next
Set Brr = Range([P18], [D65536].End(3)(1, -1)): Brr.Font.Size = 8: N = Brr.Rows.Count: Brr = Brr.Resize(10000).Resize(, 2)
For i = 1 To UBound(Brr): Z(Brr(i, 2)) = i: Next: Z.Remove ("")
Q = Array(Range([儲位!B3], [儲位!A65536].End(xlUp)), Range([儲位!E3], [儲位!D65536].End(xlUp)))
For Each Arr In Q
Arr = Arr
For i = 1 To UBound(Arr)
   T = Arr(i, 2): If Z.Exists(T) Then Brr(Z(T), 1) = Arr(i, 1) Else N = N + 1: Brr(N, 1) = Arr(i, 1): Brr(N, 2) = Arr(i, 2)
Next
Next
With [B18].Resize(N, 2): .Value = Brr: .Resize(, 15).Borders.LineStyle = 1: .EntireRow.AutoFit: End With: Call 註解_調整至指定位置
End Sub
Sub 註解_調整至指定位置()
Dim CO As Comment, SL&, ST&
For Each CO In ActiveSheet.Comments
With CO
   With Range(.Parent.Address): SL = .Left + .Width + 10: ST = .Top + 10: End With: With .Shape: .Left = SL: .Top = ST: End With
   .Shape.TextFrame.Characters.Font.Size = 12: .Shape.DrawingObject.AutoSize = True
End With
Next
Application.DisplayCommentIndicator = -1
End Sub
Sub 清除主頁篩選區資料()
With Sheets("主頁")
.Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow: .FreezePanes = False: .ScrollRow = 1: .SplitRow = 17: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
End Sub
Sub 主頁篩選區資料_全部顯示()
With Sheets("主頁")
.Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: .ScrollRow = 1: End With
If .[D65536].End(3).Row = 17 Then Call 資料彙整入主頁篩選區
End With
End Sub
Sub 空儲位()
Call 主頁篩選區資料_全部顯示: Selection.AutoFilter Field:=2, Criteria1:="<>": Selection.AutoFilter Field:=3, Criteria1:="="
End Sub
Sub 沒有儲位的鋼板()
Call 主頁篩選區資料_全部顯示: Selection.AutoFilter Field:=3, Criteria1:="<>": Selection.AutoFilter Field:=2, Criteria1:="="
End Sub

作者: aassddff736 時間: 2024-3-8 11:09

回復 17# Andy2483
哇!太更興了謝謝您很多我試試

作者: aassddff736 時間: 2024-3-8 12:40

回復 17# Andy2483

[attach]37575[/attach]

請問一下我儲存格A18向下帶入超連結儲存公式vba如何寫
=IF(D18="","",HYPERLINK("#"&LOOKUP(1,0/COUNTIF(INDIRECT({"POWER試產";"待報廢";"報廢";"1至588";"SUPER";"POWER"}&"!B:B"),D18),{"POWER試產";"待報廢";"報廢";"1至588";"SUPER";"POWER"})&"!"&"B"&MATCH(D18,INDIRECT(LOOKUP(1,0/COUNTIF(INDIRECT({"POWER試產";"待報廢";"報廢";"1至588";"SUPER";"POWER"}&"!B:B"),D18),{"POWER試產";"待報廢";"報廢";"1至588";"SUPER";"POWER"})&"!"&"B:B"),0),"●"))

作者: Andy2483 時間: 2024-3-8 13:44

回復 19# aassddff736

Sub 資料彙整入主頁篩選區()
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim Arr, Brr, Crr(1 To 10000, 1 To 1), Z, Q, i&, j%, R&, N&, S, T$, E&, TT$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("主頁")
.Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
Q = Array("1至588", "SUPER", "POWER", "POWER試產", "TEST", "待報廢", "報廢")
For Each S In Q
Set xR = [D65536].End(3)(2, 0): If Sheets(S).FilterMode = True Then Sheets(S).ShowAllData
R = Sheets(S).[B65536].End(3).Row - 2: Sheets(S).[A3].Resize(R, 14).Copy xR: If InStr("待報廢", S) Then xR.Resize(R, 1).Offset(, -1) = S
For i = 1 To xR.Resize(R, 1).Offset(, -2).Count
ActiveSheet.Hyperlinks.Add Anchor:=xR.Resize(R, 1).Offset(, 1)(i), Address:="", SubAddress:=S & "!A" & i + 2 & ":O" & i + 2
Next
Next
Set Brr = Range([P18], [D65536].End(3)(1, -1)): Brr.Font.Size = 8: Brr.Columns(3).Font.Size = 12: N = Brr.Rows.Count: Brr = Brr.Resize(10000).Resize(, 2)
For i = 1 To UBound(Brr): Z(Brr(i, 2)) = i: Next: Z.Remove ("")
Q = Array(Range([儲位!B3], [儲位!A65536].End(xlUp)), Range([儲位!E3], [儲位!D65536].End(xlUp)))
For Each Arr In Q
Arr = Arr
For i = 1 To UBound(Arr)
T = Arr(i, 2): If Z.Exists(T) Then Brr(Z(T), 1) = Arr(i, 1) Else N = N + 1: Brr(N, 1) = Arr(i, 1): Brr(N, 2) = Arr(i, 2)
Next
Next
With [B18].Resize(N, 2): .Value = Brr: .Resize(, 15).Borders.LineStyle = 1: .EntireRow.AutoFit: End With: Call 註解_調整至指定位置
End Sub

作者: aassddff736 時間: 2024-3-8 14:25

回復 20# Andy2483

謝謝您我的神

作者: aassddff736 時間: 2024-3-24 16:41

回復 20# Andy2483
請問前輩
我想做一個表單表單內容是所有空儲位點選後填入A欄表格
表單左邊"存放區域"預設全選
要如何設定?
[attach]37619[/attach]
[attach]37620[/attach]

作者: Andy2483 時間: 2024-3-26 11:13

回復 22# aassddff736

以下是學習資料驗證清單的方法,請前輩參考
儲位空位存放區清單:
[attach]37626[/attach]

儲位空位清單:
[attach]37627[/attach]

將以下代碼植入主頁工作表模組下
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
Dim Ad$, Arr, Z, xR As Range, i&
Set Arr = Intersect([主頁!B17].CurrentRegion, [主頁!B18:D65536])
If Me.UsedRange.Rows.Count <= 17 Then Exit Sub
If .Columns.Count > 1 Then Exit Sub
Set xR = Intersect(Arr.Resize(, 1), .Cells): Arr.Resize(, 2).Validation.Delete
If Not xR Is Nothing Then
   If .Count > 1 Then Exit Sub
   If Trim(.Value) = "" Then Exit Sub Else Arr = Arr
   Set Z = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(Arr)
      If Arr(i, 1) = .Value And Arr(i, 3) = "" Then Z(Arr(i, 2)) = ""
   Next
   With .Item(1, 2).Validation
      If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
      xlBetween, Formula1:=Join(Z.KEYS(), ",")
   End With
   Set Z = Nothing: Arr = Empty: Exit Sub
End If
Set xR = Intersect(Arr.Resize(, 2), .Cells)
If Not xR Is Nothing Then
   If .Count > 1 Then Exit Sub
   If .Value = "" Then Exit Sub Else Arr = Arr
   Set Z = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(Arr): Z(Arr(i, 1) & "/" & Arr(i, 2)) = i + 17: Next
   If Z.EXISTS(.Item(1, 0) & "/" & .Value) Then Rows(Z(.Item(1, 0) & "/" & .Value)).Delete
   Ad = .Cells(1, 2).Hyperlinks(1).SubAddress
   Application.Goto Sheets(Split(Ad, "!")(0)).Range(Split(Ad, "!")(1))
   Selection(1) = .Value: Set Z = Nothing: Arr = Empty
End If
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Arr, Z, i&, xR As Range
With Target
Set Arr = Intersect([主頁!B17].CurrentRegion, [主頁!B18:D65536])
Set xR = Intersect(Arr.Resize(, 1), .Cells): Arr.Resize(, 1).Validation.Delete: Arr = Arr
If Not xR Is Nothing Then
   Set Z = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(Arr)
      If Arr(i, 1) <> "" And Arr(i, 3) = "" Then Z(Arr(i, 1)) = ""
   Next
   With .Validation
      If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
      xlBetween, Formula1:=Join(Z.KEYS(), ","): Set Z = Nothing: Arr = Empty
   End With
End If
End With
End Sub

作者: aassddff736 時間: 2024-3-26 11:45

回復 23# Andy2483
謝謝您
我試試

作者: aassddff736 時間: 2024-3-26 13:07

回復 23# Andy2483
我試了跳回"清除主頁篩選區資料"會報錯
空儲位篩選資料能直接套在活頁資料下給嗎就不用跳到主頁
attachimg]37628[/attachimg]
[attach]37629[/attach]

作者: Andy2483 時間: 2024-3-26 13:34

回復 25# aassddff736

後學以往資料處理方式都是主頁為主,必要時再分檔做統計,分檔用完就清除,謝謝前輩

作者: aassddff736 時間: 2024-3-26 15:33

回復 26# Andy2483

了解
非常感謝您

作者: Andy2483 時間: 2024-3-27 11:03

本帖最後由 Andy2483 於 2024-3-27 14:06 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

Option Explicit
Sub 不重複各欄明細()
Dim Brr, Crr, Z, Q, i&, j%, R&, T$, x%, Rm&
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([主頁!B17].CurrentRegion, [主頁!B17:P65536])
ReDim Crr(10000, 1 To UBound(Brr, 2))
For j = 1 To UBound(Brr, 2)
For i = 2 To UBound(Brr)
   Q = Split(Brr(i, j) & Chr(10), Chr(10))
   For x = 0 To UBound(Q) - 1
      T = Trim(Q(x))
      If Not Z.Exists(T) And T <> "" Then R = R + 1: Crr(R, j) = T: Z(T) = "": Rm = IIf(R > Rm, R, Rm)
   Next
Next
Crr(0, j) = Brr(1, j): R = 0: Z.RemoveAll
Next
Workbooks.Add
With [A1].Resize(Rm + 1, UBound(Brr, 2))
.NumberFormat = "@": .Value = Crr: .EntireColumn.AutoFit
For j = 1 To UBound(Brr, 2): .Columns(j).Sort KEY1:=.Cells(1, j), Order1:=1, Header:=1: Next
End With
End Sub

作者: aassddff736 時間: 2024-3-27 13:59

回復 28# Andy2483
沒有明白

作者: Andy2483 時間: 2024-3-27 14:04

本帖最後由 Andy2483 於 2024-3-27 14:07 編輯

回復 29# aassddff736

純練習,請參考,目的是整理出每個欄位輸入過的項目(不重複並且做排序)
執行結果:
[attach]37631[/attach]

作者: aassddff736 時間: 2024-3-27 14:13

回復 30# Andy2483 [/b
了解

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)