返回列表 上一主題 發帖

[發問] 篩選相關的數據

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 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
複製代碼
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
2#
發表於 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
複製代碼
執行結果如下:

TOP

        靜思自在 : 君子立恆志，小人恆立志。
返回列表 上一主題