返回列表 上一主題 發帖

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

rouber590324

帖子
561 
主題
160 
精華
0 
積分
725 
點名
0  
作業系統
WINDOWS 
軟體版本
xp 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2014-9-10 
最後登錄
2024-8-7 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2017-9-27 08:52 | 只看該作者

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

DEAR ALL 大大
1.資料庫如圖一
2.需求-編號前七碼相同者只要銷案日空值則其他版次皆刪除
2.1 例: C123456 與 C123456A 組.因 銷案日皆有值為同一故保留.
          D123456 與 D123456A 與 D123456B 為同一組因D123456B銷案日為空白故ALL刪除
       E123456 與 E123456A 為同一組因E123456銷案日為空白故ALL刪除
2.2 結果如圖二
3.煩不吝賜教  THANKS*10000

圖一
編號         項目   使用者     收件日           銷案日
C123456      1        1          2017/08/04        2017/08/12
C123456A      1        1          2017/08/04        2017/08/12
D123456        1        1          2017/08/04        2017/08/12
D123456A      1        1          2017/08/04        2017/08/12
E123456        1        1          2017/08/04         
D123456B      1        1          2017/08/04
E123456A      1        1          2017/08/05        2017/08/06

圖二
C123456        1        1          2017/08/04        2017/08/12
C123456A      1        1          2017/08/04        2017/08/12
收藏 分享
羅

hcm19522

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

熱烈參與勳章
2#
發表於 2017-9-27 10:44 | 只看該作者
http://blog.xuite.net/hcm19522/twblog/536264306
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

rouber590324

帖子
561 
主題
160 
精華
0 
積分
725 
點名
0  
作業系統
WINDOWS 
軟體版本
xp 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2014-9-10 
最後登錄
2024-8-7 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章
3#
發表於 2017-9-27 10:51 | 只看該作者
DEAR  大大
SORRY 未說清處
小弟是要使用VBA
原圖一資料庫於   SHEET1
要將圖二資料導入 SHEET2
羅

TOP

rouber590324

帖子
561 
主題
160 
精華
0 
積分
725 
點名
0  
作業系統
WINDOWS 
軟體版本
xp 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2014-9-10 
最後登錄
2024-8-7 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章
4#
發表於 2017-9-27 13:53 | 只看該作者
DEAR ALL 大大
小弟分如下4組方完成
請教如何一組VAB即完成之方式 煩不吝賜教

Sub 條件資料庫A()
Application.Run "條件資料庫A1"
Application.Run "條件資料庫A2"
Application.Run "條件資料庫A3"
Sheet3.[a2:f65536].ClearContents
  X = Sheet1.[A65536].End(xlUp).Row
  Y = Sheet3.[A65536].End(xlUp).Row
For M = 2 To X
If Sheet1.Cells(M, 9) = 0 Then
  Sheet3.Cells(Y + 1, 1).Resize(, 6).Value = Sheet1.Cells(M, 1).Resize(, 6).Value
    Y = Y + 1
End If
Next
End Sub

Sub 條件資料庫A1()
Sheet1.[G2:G65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
  Sheet1.Cells(M, 7) = Mid(Sheet1.Cells(M, 1), 1, 7)
  Next
End Sub

Sub 條件資料庫A2()
Sheet1.[H2:H65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
  If Sheet1.Cells(M, 5) = "NULL" Or Sheet1.Cells(M, 5) = "" Or Sheet1.Cells(M, 5) = " " Then
    Sheet1.Cells(M, 8) = Sheet1.Cells(M, 7)
  End If
  Next
End Sub

Sub 條件資料庫A3()
Sheet1.Select
Range("A1").Select
Sheet1.[I2:I65536].ClearContents
X = Sheet1.[A65536].End(xlUp).Row
For M = 2 To X
   Sheet1.Cells(M, 9) = Application.CountIf(Sheet1.Range("H:H"), Sheet1.Cells(M, 7))
Next
End Sub
羅

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 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

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
6#
發表於 2017-9-27 21:08 | 只看該作者
回復 3# rouber590324
請參考。
依編號銷案.rar (17.64 KB)

TOP

rouber590324

帖子
561 
主題
160 
精華
0 
積分
725 
點名
0  
作業系統
WINDOWS 
軟體版本
xp 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2014-9-10 
最後登錄
2024-8-7 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章
7#
發表於 2017-9-28 09:28 | 只看該作者
DEAR Hsieh 大大
1.出現型態不符合之BUG停於ay(3) = CDate(ay(3))????

DEAR Kubi 大大
小弟使用公司電腦無法下載.rar檔案.還是感謝您回覆.

Sub 條件資料庫A4()
Dim A As Range
Set d = CreateObject("Scripting.Dictionary")
With Sheets(1)
For Each A In .Range(.[A1], .[A1].End(xlDown))
  If d(Left(A, 7)) = "" Then
     d(Left(A, 7)) = Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
     Else
     d(Left(A, 7)) = d(Left(A, 7)) & Chr(10) & Join(Application.Transpose(Application.Transpose(A.Resize(, 5))), ";")
  End If
Next
For Each ky In d.keys
  ar = Split(d(ky), Chr(10))
For Each c In ar
     If Split(c, ";")(4) = "" Then d.Remove ky
  Next
Next
'On Error Resume Next
For Each ky In d.keys
  ar = Split(d(ky), Chr(10))
  For Each c In ar
  ay = Split(c, ";")
  ay(3) = CDate(ay(3))
  ay(4) = CDate(ay(4))
    Sheets(2).Cells(r + 1, 1).Resize(, 5) = ay
    r = r + 1
  Next
Next
End With
End Sub
羅

TOP

rouber590324

帖子
561 
主題
160 
精華
0 
積分
725 
點名
0  
作業系統
WINDOWS 
軟體版本
xp 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2014-9-10 
最後登錄
2024-8-7 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章
8#
發表於 2017-9-28 09:45 | 只看該作者
DEAR Hsieh 大大
SORRY 已找到問題.感謝您之指導 THANKS*10000
羅

TOP

        靜思自在 : 發脾氣是短暫的發瘋。
返回列表 上一主題