麻辣家族討論版版 » Excel程式區 » 篩選相關的數據

返回列表下一主題上一主題發帖

[發問] 篩選相關的數據

小學生 Rank: 1

帖子: 12
主題: 5
精華: 0
積分: 18
點名: 0
作業系統: WINDOWS
軟體版本: OFFICE2013
閱讀權限: 10
註冊時間: 2014-11-12
最後登錄: 2022-11-29

論壇贊助勳章

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-12-22 11:00 | 只看該作者

[發問] 篩選相關的數據

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

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

問題.rar (15.43 KB)

樓主熱帖

收藏

大學生 Rank: 4

帖子: 1364
主題: 4
精華: 0
積分: 1374
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-5-3

熱烈參與勳章

2^#

發表於 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)),"")

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2804
主題: 10
精華: 0
積分: 2860
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-3

3^#

發表於 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　

高中生 Rank: 3 Rank: 3

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

4^#

發表於 2015-12-22 16:04 | 只看該作者

試試看:

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

複製代碼

小學生 Rank: 1

帖子: 12
主題: 5
精華: 0
積分: 18
點名: 0
作業系統: WINDOWS
軟體版本: OFFICE2013
閱讀權限: 10
註冊時間: 2014-11-12
最後登錄: 2022-11-29

論壇贊助勳章

5^#

發表於 2015-12-22 17:09 | 只看該作者

回復 2# hcm19522

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

小學生 Rank: 1

帖子: 12
主題: 5
精華: 0
積分: 18
點名: 0
作業系統: WINDOWS
軟體版本: OFFICE2013
閱讀權限: 10
註冊時間: 2014-11-12
最後登錄: 2022-11-29

論壇贊助勳章

6^#

發表於 2015-12-22 17:09 | 只看該作者

回復 3# 准提部林

這真是太神了，感謝

小學生 Rank: 1

帖子: 12
主題: 5
精華: 0
積分: 18
點名: 0
作業系統: WINDOWS
軟體版本: OFFICE2013
閱讀權限: 10
註冊時間: 2014-11-12
最後登錄: 2022-11-29

論壇贊助勳章

7^#

發表於 2015-12-22 17:10 | 只看該作者

回復 4# yen956

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

高中生 Rank: 3 Rank: 3

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

8^#

發表於 2015-12-22 17:33 | 只看該作者

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

Private Sub CommandButton1_Click()
Dim sh1 As Worksheet
Dim c0 As Long, r0 As Long, LstR0 As Long, cnt As Integer
Dim c1 As Long, r1 As Long, LstR1 As Long, msg As Integer
Set sh1 = Sheets("工作表1")
msg = MsgBox("要清除 [工作表1] 中原有資料嗎?", vbYesNo)
If msg = vbYes Then
sh1.Cells.Clear
[A1].Copy sh1.[A1]
End If
LstR0 = Cells(Rows.Count, "B").End(xlUp).Row
LstR1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row
For r0 = Int(LstR1 / 5) * 6 + 2 To LstR0 Step 6
r1 = Int(r0 / 6) * 5 + 2
Cells(r0, 1).Resize(4, 2).Copy sh1.Cells(r1, 1)
cnt = 2
For c0 = 3 To 26
If Cells(r0, c0) >= 36 Then
cnt = cnt + 1
Cells(1, c0).Copy sh1.Cells(r1 - 1, cnt)
Cells(r0, c0).Resize(4, 1).Copy sh1.Cells(r1, cnt)
End If
Next
Next
End Sub

複製代碼

執行結果如下:

小學生 Rank: 1

帖子: 12
主題: 5
精華: 0
積分: 18
點名: 0
作業系統: WINDOWS
軟體版本: OFFICE2013
閱讀權限: 10
註冊時間: 2014-11-12
最後登錄: 2022-11-29

論壇贊助勳章

9^#

發表於 2015-12-22 18:46 | 只看該作者

回復 8# yen956

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

靜思自在 : 人生不一定球球是好球，但是有歷練的強打者，隨時都可以揮棒。

返回列表下一主題上一主題