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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2018-4-30 14:26 | 只看該作者

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

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

高中生 Rank: 3 Rank: 3

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

8^#

發表於 2018-5-4 11:25 | 只看該作者

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

羅

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

7^#

發表於 2018-5-2 12:46 | 只看該作者

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

複製代碼

TOP

rouber590324

高中生 Rank: 3 Rank: 3

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

6^#

發表於 2018-5-2 10:38 | 只看該作者

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

羅

TOP

hcm19522

大學生 Rank: 4

帖子: 1438
主題: 12
精華: 0
積分: 1456
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2025-10-24

熱烈參與勳章

5^#

發表於 2018-5-2 10:36 | 只看該作者

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

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2018-5-2 09:40 | 只看該作者

Sub ex()
Set dic = CreateObject("Scripting.Dictionary")
With Sheets(1)
For Each a In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
If IsEmpty(dic(a & a.Offset(, 1))) Then
ar = Application.Transpose(Application.Transpose(a.Resize(, 4).Value))
dic(a & a.Offset(, 1)) = ar
Else
ar = dic(a & a.Offset(, 1))
ar(4) = a.Offset(, 3)
dic(a & a.Offset(, 1)) = ar
End If
Next
End With
Sheets(2).[A:D].ClearContents
Sheets(2).[A1].Resize(dic.Count, 4) = Application.Transpose(Application.Transpose(dic.items))
End Sub