[發問] 報價查詢

最近在excel 2010下練習報價查詢
部分功能無法達到預期要求...在此求助

而程式的寫法希望大大可以幫忙精簡...多謝

多條件篩選.rar (146.93 KB)

50 字節以內
不支持自定義 Discuz! 代碼

2^#

發表於 2012-11-23 16:20 | 只看該作者

回復 1# softsadwind

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
'clear
Range("G4").Resize(UsedRange.Rows.Count - 3, 4).Clear
Sheets("篩選").Range("G:J").Clear
'filter copy
Range("A:D").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("G1:I2"), CopyToRange:=Sheets("篩選").Range("G:J"), Unique:=False
'sort, copy back
Dim R2 As Long
With Sheets("篩選")
R2 = .Range("G65536").End(xlUp).Row
.Range("G1:J" & R2).Sort Key1:=.Range("I2:I" & R2), Key2:=.Range("G2:G" & R2), Key3:=.Range("H2:H" & R2), Header:=xlYes
.Range("I1:I" & R2).Copy [G4]
.Range("G1:H" & R2).Copy [H4]
.Range("J1:J" & R2).Copy [J4]
End With
'格式框線
Dim i, j
With Range(Range("G4"), Range("G4").End(xlDown))
For i = .Columns(1).Rows.Count To 2 Step -1
'product
If .Cells(i, 1).Value <> .Cells(i - 1, 1) Then
.Cells(i, 1).Resize(, 4).Borders(xlEdgeTop).LineStyle = xlContinuous
Else
.Cells(i, 1).Value = ""
.Cells(i, 1).Borders(xlEdgeTop).LineStyle = xlNone
'customer
If .Cells(i, 2).Value <> .Cells(i - 1, 2) Then
.Cells(i, 2).Resize(, 3).Borders(xlEdgeTop).LineStyle = xlContinuous
Else
.Cells(i, 2).Value = ""
.Cells(i, 2).Resize(, 3).Borders(xlEdgeTop).LineStyle = xlNone
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

複製代碼

3^#

發表於 2012-11-23 21:31 | 只看該作者

回復 2# stillfish00

謝謝根據你的寫法又讓我看到更精簡的vba寫法多謝指導!!

50 字節以內
不支持自定義 Discuz! 代碼