[發問] 篩選相關的數據

doulioufire

各位高手，如圖片（圖一）所表示，當PM2.5大於36的時候，風向的數據會自動跑到另一個表單（如圖二）

下載 (55.34 KB)

2015-12-22 10:54

下載 (28.55 KB)
圖二

2015-12-22 11:00

hcm19522

C2:R20{=IFERROR(IF(MOD(ROW(A1),5)=0,"",OFFSET(嘉義!$A$1,INT((ROW(A1)-1)/5)*6+MOD(ROW(A1),5),SMALL(IF(OFFSET(嘉義!$C$2,MAX(INT(ROW(A1)/5)*6),,,24)>=36,COLUMN($C:$Z)),COLUMN(A1))-1)),"")

准提部林

Sub TEST1()
Dim xR As Range, xH As Range, xU As Range, j&
Sheets("工作表1").UsedRange.Clear
Set xH = [工作表1!A2]
[嘉義!A1].Copy xH(0)
For Each xR In Range([嘉義!A2], [嘉義!A65536].End(xlUp))
　　If xR.Row = 1 Then Exit Sub
　　If xR = "" Then GoTo 101
　　Set xU = xR.Resize(6, 2)
　　For j = [C1].Column To [Z1].Column
　　　　If xR(1, j) >= 36 Then Set xU = Union(xU, xR(1, j).Resize(6))
　　Next j
　　xU.Copy xH
　　Set xH = xH(8)
101: Next
End Sub　

yen956

試試看:

1. Private Sub CommandButton1_Click()
   
2.     Dim sh1 As Worksheet
   
3.     Dim c0 As Long, r0 As Long, LstR0 As Long, cnt As Integer
   
4.     Dim c1 As Long, r1 As Long, LstR1 As Long, msg As Integer
   
5.     Set sh1 = Sheets("工作表1")
   
6.     LstR0 = Cells(Rows.Count, "B").End(xlUp).Row
   
7.     LstR1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row
   
8.     If LstR0 - 2 = LstR1 Then
   
9.         msg = MsgBox("工作表1中, " & Cells(LstR0 - 5, "A") & " 的資料已經存在, 要覆蓋嗎?", vbOKCancel)
   
10.         If msg = vbCancel Then Exit Sub
    
11.     End If
    
12.     For r0 = LstR1 + 3 To LstR0 Step 6
    
13.         Cells(r0, 1).Resize(4, 2).Copy sh1.Cells(r0, 1)
    
14.         cnt = 2
    
15.         For c0 = 3 To 26
    
16.             If Cells(r0, c0) >= 36 Then
    
17.                 cnt = cnt + 1
    
18.                 sh1.Cells(r0 - 1, cnt) = Cells(1, c0)
    
19.                 sh1.Cells(r0 - 1, cnt) = Format(sh1.Cells(r0 - 1, cnt), "hh:mm;@")
    
20.                 Cells(r0, c0).Resize(4, 1).Copy sh1.Cells(r0, cnt)
    
21.             End If
    
22.         Next
    
23.     Next
    
24. End Sub

複製代碼

下載 (326.09 KB)

2015-12-22 16:03

doulioufire

回復 2# hcm19522


    感謝高手的回答，我在嘗試看看！

doulioufire

回復 3# 准提部林


    這真是太神了，感謝

doulioufire

回復 4# yen956


    感謝，還製作動畫，哈哈，在一次的感謝

yen956

對不起, 因考慮到你可能需要 時間,
測試時有稍稍修改表格, 忘了改回來,
表格已改回來了, 也已重新修正VBA,
只增加時間而己, 其他不變, 試試看!!

1. Private Sub CommandButton1_Click()
   
2.     Dim sh1 As Worksheet
   
3.     Dim c0 As Long, r0 As Long, LstR0 As Long, cnt As Integer
   
4.     Dim c1 As Long, r1 As Long, LstR1 As Long, msg As Integer
   
5.     Set sh1 = Sheets("工作表1")
   
6.     msg = MsgBox("要清除 [工作表1] 中原有資料嗎?", vbYesNo)
   
7.     If msg = vbYes Then
   
8.         sh1.Cells.Clear
   
9.         [A1].Copy sh1.[A1]
   
10.     End If
    
11.     LstR0 = Cells(Rows.Count, "B").End(xlUp).Row
    
12.     LstR1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row
    
13.     For r0 = Int(LstR1 / 5) * 6 + 2 To LstR0 Step 6
    
14.         r1 = Int(r0 / 6) * 5 + 2
    
15.         Cells(r0, 1).Resize(4, 2).Copy sh1.Cells(r1, 1)
    
16.         cnt = 2
    
17.         For c0 = 3 To 26
    
18.             If Cells(r0, c0) >= 36 Then
    
19.                 cnt = cnt + 1
    
20.                 Cells(1, c0).Copy sh1.Cells(r1 - 1, cnt)
    
21.                 Cells(r0, c0).Resize(4, 1).Copy sh1.Cells(r1, cnt)
    
22.             End If
    
23.         Next
    
24.     Next
    
25. End Sub

複製代碼

執行結果如下:

下載 (142.52 KB)

2015-12-22 17:30

doulioufire

回復 8# yen956


    太用了心了，感謝高手的協助