返回列表 上一主題 發帖

關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2016-2-22 16:21 | 顯示全部帖子
  1. Sub ex()
  2. Dim ar(0 To 1), ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("彙總表")
  5. For Each a In .Range(.[B5], .[B5].End(xlDown))
  6.    If IsEmpty(d(a & "")) Then
  7.       ar(0) = Array(.[B4], .[C4], .[D4], .[E4])
  8.       ar(1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  9.       d(a & "") = ar
  10.       Else
  11.       ay = d(a & "")
  12.       s = UBound(ay)
  13.       ReDim Preserve ay(s + 1)
  14.       ay(s + 1) = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
  15.       d(a & "") = ay
  16.       Erase ay
  17.     End If
  18. Next
  19. For Each sh In Sheets
  20.    If d.exists(sh.Name) = True Then
  21.       ay = d(sh.Name)
  22.       sh.[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  23.       d.Remove sh.Name
  24.     End If
  25. Next
  26. For Each ky In d.keys
  27.    With Sheets.Add(after:=Sheets(Sheets.Count))
  28.       .Name = ky
  29.        ay = d(ky)
  30.       .[B4].Resize(UBound(ay) + 1, 4) = Application.Transpose(Application.Transpose(ay))
  31.     End With
  32. Next
  33. End With
  34. End Sub
複製代碼
回復 1# 學到老死
學海無涯_不恥下問

TOP

        靜思自在 : 不怕事多，只怕多事。
返回列表 上一主題