返回列表 上一主題 發帖

[發問] 編號前七碼相同者只要銷案日空值則其他版次皆刪除

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2017-9-27 16:39 | 顯示全部帖子
回復 4# rouber590324
試試看
  1. Sub ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets(1)
  5. For Each A In .Range(.[A1], .[A1].End(xlDown))
  6.   If d(Left(A, 7)) = "" Then
  7.      d(Left(A, 7)) = Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
  8.      Else
  9.      d(Left(A, 7)) = d(Left(A, 7)) & Chr(10) & Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
  10.   End If
  11. Next
  12. For Each ky In d.keys
  13.   ar = Split(d(ky), Chr(10))
  14.   For Each c In ar
  15.      If Split(c, ";")(4) = "" Then d.Remove ky
  16.   Next
  17. Next
  18. On Error Resume Next
  19. For Each ky In d.keys
  20.   ar = Split(d(ky), Chr(10))
  21.   For Each c In ar
  22.   ay = Split(c, ";")
  23.   ay(3) = CDate(ay(3))
  24.   ay(4) = CDate(ay(4))
  25.     Sheets(2).Cells(r + 1, 1).Resize(, 5) = ay
  26.     r = r + 1
  27.   Next
  28. Next
  29. End With
  30. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 對父母要知恩，感恩、報恩。
返回列表 上一主題