Board logo

標題: [發問] 查詢後傳回多筆資料以樹狀目錄方式置放 [打印本頁]
作者: jesscc    時間: 2011-10-21 21:48     標題: 查詢後傳回多筆資料以樹狀目錄方式置放

工作有點複雜，在附檔中有詳細說明

[attach]8301[/attach]
作者: Hsieh    時間: 2011-10-21 22:34

回復 1# jesscc
查詢
  1. Sub query()
  2. Dim i%, Ar(), A As Range
  3. If Sheet33.OptionButton7.Object.Value = True Then
  4. Set d = CreateObject("Scripting.Dictionary")
  5. Set d1 = CreateObject("Scripting.Dictionary")
  6.     With Sheets("DATA")
  7.         For Each A In Range(.[B5], .[B65536].End(xlUp))
  8.             d(A.Value) = A.Offset(, 3).Value
  9.             d1(A.Value) = Array(A.Value, "", A.Offset(, 3).Value, A.Offset(, 4).Value, A.Offset(, 10).Value)
  10.         Next
  11.     End With
  12.     With Sheets("B")
  13.         For Each A In Range(.[D12], .[D65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
  14.            For Each ky In d.keys
  15.               If ky <> A And d(ky) = d(A.Value) Then
  16.               ReDim Preserve Ar(s)
  17.               Ar(s) = d1(ky)
  18.               s = s + 1
  19.               End If
  20.            Next
  21.            If s > 0 Then
  22.            A.Offset(1, 0).Resize(s, 1).EntireRow.Insert
  23.            A.Offset(1, 1).Resize(s, 5) = Application.Transpose(Application.Transpose(Ar))
  24.            s = 0: Erase Ar
  25.            End If
  26.         Next
  27.     End With
  28. End If
  29. Set d = Nothing
  30. Set d1 = Nothing
  31. End Sub
複製代碼
替代料
  1. Private Sub OptionButton7_Click()
  2. Dim i%
  3. [E11] = "替代料"
  4. Columns("G:J").EntireColumn.Hidden = False
  5. Var = MsgBox("這樣做會刪除你之前所做的查詢結果。" & vbCrLf & vbCrLf & "但不會刪除原來的 PN。" & vbCrLf & vbCrLf & "請確定你要進行的查詢項目 !" & vbCrLf & vbCrLf & "可以按""取消""離開!", 33, "操作步驟提示!")
  6.      If Var = 2 Then
  7.      OptionButton6 = True
  8.      Columns("G:J").EntireColumn.Hidden = True
  9.        Exit Sub
  10.      Else
  11.      Range([E12], Cells(Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
  12.      End If
  13.   End Sub
複製代碼
作者: jesscc    時間: 2011-10-22 11:09

本帖最後由 jesscc 於 2011-10-22 14:08 編輯

回復 2# Hsieh


    感謝H大幫忙!
程式運作大致OK，刪除列的時候有點小問題，我把原始檔Sub query()的部分做了一些修改，加入了OpenOrder的查詢，本來還想說應該不難，因為這個部分不用考量排除原始PN的問題，只有資料放置的問題。我用Call的方式，在一個Sub裡去Call不同的查詢，結果OpenOrder的部分無法正常查詢(偵錯:此處需要物件)，而且如果一直按"查詢"按鈕，會連標題列都被刪除，不知哪裡有問題，快瘋了><

[attach]8308[/attach]
作者: jesscc    時間: 2011-10-22 22:44

本帖最後由 jesscc 於 2011-10-22 22:45 編輯

已修正錯刪標題列的問題，並且也可以查詢了，只是查詢結果不符所需，只能傳回最後一筆
  1. Sub query1()
  2. Dim i%, Ar(), A As Range
  3. If [E13] <> "" Then
  4.      Columns("G:I").EntireColumn.Hidden = True
  5.      Range([E13], Cells(Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
  6. AA:
  7. Set d = CreateObject("Scripting.Dictionary")
  8. Set d1 = CreateObject("Scripting.Dictionary")

  10.     With Sheets("OpenOrder")
  11.         For Each A In Range(.[E7], .[E65536].End(xlUp))
  12.             d(A.Value) = A.Offset(, 2).Value
  13.             d1(A.Value) = Array(A.Value, A.Offset(, 1).Value, "", "", "", A.Offset(, 5).Value, "", "", A.Offset(, 8).Value, A.Offset(, 9).Value, A.Offset(, 10).Value, A.Offset(, 11).Value, A.Offset(, 12).Value)
  14.         Next
  15.     End With
  16.     With Sheets("B")
  17.         For Each A In Range(.[D12], .[D65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
  18.            For Each ky In d.keys
  19.               If ky = A Then
  20.               ReDim Preserve Ar(s)
  21.               Ar(s) = d1(ky)
  22.               s = s + 1
  23.               End If
  24.            Next
  25.            
  26.            If s > 0 Then
  27.            A.Offset(1, 0).Resize(s, 1).EntireRow.Insert
  28.            A.Offset(1, 1).Resize(s, 13) = Application.Transpose(Application.Transpose(Ar))
  29.            s = 0: Erase Ar
  30.            End If
  31.         Next
  32.     End With


  35. Set d = Nothing
  36. Set d1 = Nothing
  37. Else
  38. GoTo AA
  39. End If
  40. End Sub
複製代碼




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