Board logo

標題: [發問] 篩選相關的數據 [打印本頁]
作者: doulioufire    時間: 2015-12-22 11:00     標題: 篩選相關的數據

本帖最後由 doulioufire 於 2015-12-22 11:03 編輯

各位高手，如圖片（圖一）所表示，當PM2.5大於36的時候，風向的數據會自動跑到另一個表單（如圖二）
[attach]22914[/attach]
[attach]22915[/attach]
作者: hcm19522    時間: 2015-12-22 15:04

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)),"")
作者: 准提部林    時間: 2015-12-22 15:14

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    時間: 2015-12-22 16:04

試試看:
  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
複製代碼
[attach]22924[/attach]
作者: doulioufire    時間: 2015-12-22 17:09

回復 2# hcm19522


    感謝高手的回答，我在嘗試看看！
作者: doulioufire    時間: 2015-12-22 17:09

回復 3# 准提部林


    這真是太神了，感謝
作者: doulioufire    時間: 2015-12-22 17:10

回復 4# yen956


    感謝，還製作動畫，哈哈，在一次的感謝
作者: yen956    時間: 2015-12-22 17:33

對不起, 因考慮到你可能需要 時間,
測試時有稍稍修改表格, 忘了改回來,
表格已改回來了, 也已重新修正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
複製代碼
執行結果如下:
[attach]22928[/attach]
作者: doulioufire    時間: 2015-12-22 18:46

回復 8# yen956


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



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