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

rouber590324

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

http://blog.xuite.net/hcm19522/twblog/536264306

rouber590324

DEAR  大大
SORRY 未說清處
小弟是要使用VBA
原圖一資料庫於   SHEET1
要將圖二資料導入 SHEET2

rouber590324

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

Hsieh

回復 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

複製代碼

Kubi

回復 3# rouber590324
請參考。
依編號銷案.rar (17.64 KB)

下載次數: 1

2017-9-27 21:07

rouber590324

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

rouber590324

DEAR Hsieh 大大
SORRY 已找到問題.感謝您之指導 THANKS*10000