- 帖子
- 162
- 主題
- 44
- 精華
- 0
- 積分
- 244
- 點名
- 0
- 作業系統
- windows 7
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2011-4-4
- 最後登錄
- 2022-10-3
|
本帖最後由 jesscc 於 2011-10-22 22:45 編輯
已修正錯刪標題列的問題，並且也可以查詢了，只是查詢結果不符所需，只能傳回最後一筆- Sub query1()
- Dim i%, Ar(), A As Range
- If [E13] <> "" Then
- Columns("G:I").EntireColumn.Hidden = True
- Range([E13], Cells(Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
- AA:
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- With Sheets("OpenOrder")
- For Each A In Range(.[E7], .[E65536].End(xlUp))
- d(A.Value) = A.Offset(, 2).Value
- 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)
- Next
- End With
- With Sheets("B")
- For Each A In Range(.[D12], .[D65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
- For Each ky In d.keys
- If ky = A Then
- ReDim Preserve Ar(s)
- Ar(s) = d1(ky)
- s = s + 1
- End If
- Next
-
- If s > 0 Then
- A.Offset(1, 0).Resize(s, 1).EntireRow.Insert
- A.Offset(1, 1).Resize(s, 13) = Application.Transpose(Application.Transpose(Ar))
- s = 0: Erase Ar
- End If
- Next
- End With
- Set d = Nothing
- Set d1 = Nothing
- Else
- GoTo AA
- End If
- End Sub
|
|
發表於 2011-10-21 21:48
| 
