[發問] 上班時間問題請教

rouber590324

DEAR ALL 大大
1. SHEET1 之資料庫內容如下
            A欄姓名                B欄日期                 C欄入廠時間                D欄出廠時間  
2列       卜鴻義                1070321               10703210759               10703211712
3列        魏士杰               1070321               10703210755               10703211203
4列       魏士杰                1070321               10703211254               10703211723   
5列       楊佳振                1070322               10703220753               10703221706
..........................................
2.問題點: 部分中午有外出用餐之人員會有2筆打卡資料(例:魏士杰 0321 有2筆  10703210755-10703211203 與 10703211254-10703211723 資料      )
3.需求於 SHEET2 內將 中午有外出用餐之2筆資料整合為一筆(例:魏士杰 0321 有2筆資料整合為 10703210755      10703211723  一筆上下班打卡時間資料 )      
   3.1. SHEET2 之資料庫內容如下
            A欄姓名                B欄日期                 C欄入廠時間                D欄出廠時間  
2列       卜鴻義                1070321               10703210759               10703211712
3列        魏士杰               1070321               10703210755               10703211723
4列       楊佳振                1070322               10703220753               10703221706
..........................................
4.煩不吝賜教.  THANKS*10000

准提部林

請上傳檔案~~才好參考

rouber590324

DER  准提部林  大大
1.公司電腦,限制無法上傳檔案與下載檔案.
   故方用文字書寫.尚請見諒.SORRY*10000

Hsieh

1. Sub ex()
   
2. Set dic = CreateObject("Scripting.Dictionary")
   
3. With Sheets(1)
   
4. For Each a In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
   
5. If IsEmpty(dic(a & a.Offset(, 1))) Then
   
6. ar = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
   
7.    dic(a & a.Offset(, 1)) = ar
   
8.    Else
   
9. ar = dic(a & a.Offset(, 1))
   
10. ar(4) = a.Offset(, 3)
    
11.    dic(a & a.Offset(, 1)) = ar
    
12. End If
    
13. Next
    
14. End With
    
15. Sheets(2).[A:D].ClearContents
    
16. Sheets(2).[A1].Resize(dic.Count, 4) = Application.Transpose(Application.Transpose(dic.items))
    
17. End Sub

複製代碼

回復 3# rouber590324

hcm19522

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

rouber590324

DEAR  Hsieh  大大
感謝您之指導.100%符合需求  thanks*10000

准提部林

1. Sub TEST()
   
2. Dim Arr, i&, j%, T$, xD, U&, N&
   
3. Arr = Range([Sheet1!D1], [Sheet1!A1].Cells(Rows.Count, 1).End(xlUp))
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. For i = 2 To UBound(Arr)
   
6.     T = Arr(i, 1) & Arr(i, 2):  U = xD(T)
   
7.     If U = 0 Then
   
8.        N = N + 1: xD(T) = N: U = N
   
9.        For j = 1 To 4: Arr(U + 1, j) = Arr(i, j): Next
   
10.     End If
    
11.     Arr(U + 1, 4) = Arr(i, 4)
    
12. Next i
    
13. 
    
14. Sheets("Sheet2").UsedRange.EntireRow.Delete
    
15. Sheets("Sheet2").[A1:D1].Resize(N + 1) = Arr
    
16. End Sub

複製代碼

rouber590324

DEAR 准提部林 大大
感謝您之指導.100%符合需求  thanks*10000