返回列表 上一主題 發帖

[發問] 考勤表VBA難題求助

[發問] 考勤表VBA難題求助

本人一直學習VBA及爬文, 發現單一VBA問題不大, 但要個功能就墮入困局, 又是考勤表問題, 期望給予協助:
考勤表 20150815.rar (109.15 KB)

從學習書內抄考用了相信是愚蠢的方法, 求教::Q

Sub match2()
'combine id card no and date for searching


Dim srcrange As Range, fndrange As Range
Dim fstaddress As String, i As Integer
Dim fc As Integer
Dim fr As Integer
Dim fr2 As Integer



Worksheets("attendance report").Activate

fc = 12
fr = 4
fr2 = 3

Set srcrange = Worksheets("data").Range("a4").CurrentRegion.Columns(9)
Set fndrange = srcrange.Find(what:=Range(fr, fc) & Range("v" & fr2).Value)

If Not fndrange Is Nothing Then

fstaddress = fndrange.Address

i = 5

Do
Cells(i, 22).Value = fndrange.Offset(, 0).Value
Cells(i + 1, 22).Value = fndrange.Offset(1, 0).Value
Cells(i + 8, 22).Value = fndrange.Offset(2, 0).Value
Cells(i + 9, 22).Value = fndrange.Offset(3, 0).Value

i = 1 + 1

Loop Until findrange.Address = fstaddress

Else

MsgBox "XX"
End If



End Sub

回復 19# GBKEE


我改動了設計, 暫不 用更改了,     感謝賜教!

TOP

回復 16# lpk187


        感謝賜教!

TOP

回復 18# missbb

你附檔的ee data 員工只有2位,可多舉一些.看看
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 14# GBKEE

想問為何可以取得姓名呢?因為我在EE DATA及EE內都找不到對應的欄?

           .Parent.Cells(.Row + X + 1, "d").Resize(20) = Rng

另可否從EE DATA一版內將員工編號及部門都放在ATTENDANCE內並顯示20列呢?

有勞賜教!

TOP

回復 16# lpk187
多謝指導.

TOP

回復 15# missbb

ActiveSheet.Range("A4:AP23").Select
   
    Selection.Copy次<<這裡裡是選擇上面範圍A4:AP23製範圍的複製
但下面的紅色部份卻把上面的選擇更換掉了,所以它只能貼一次,第二次就會出錯了!
For i = 1 To QQQQ
     ActiveSheet.Range("A" & 1 + i * 20).Select
    ActiveSheet.Paste
  Next i
要複製貼上,只要一句就可解決,如下範例:
  1. Sub COPY_FORMAT()
  2. Dim i As Integer
  3.     Worksheets("attendance report").Activate
  4.     QQQQ = Worksheets("ee data").Cells(Rows.Count, "b").End(xlUp).Row
  5. For i = 1 To QQQQ
  6.     ActiveSheet.Range("A4:AP23").Copy Range("A" & 1 + i * 20)
  7. Next i
  8. End Sub
複製代碼

TOP

回復 14# GBKEE
想請教將("A4:AP23") COPY 等如員工人數的次數, 但出錯, 是甚麼原因?
  1. [code]Sub COPY_FORMAT()

  2. Dim i As Integer

  3.     Worksheets("attendance report").Activate
  4.    
  5.     QQQQ = Worksheets("ee data").Cells(Rows.Count, "b").End(xlUp).Row
  6.    
  7.     ActiveSheet.Range("A4:AP23").Select
  8.    
  9.     Selection.Copy
  10.    
  11. For i = 1 To QQQQ
  12.    
  13.     ActiveSheet.Range("A" & 1 + i * 20).Select
  14.     ActiveSheet.Paste
  15.   
  16. Next i
  17. End Sub

  18.         


  19.    
複製代碼
[/code]

TOP

回復 13# missbb
字典物件,也可試試看.
  1. Option Explicit
  2. Sub Ex()
  3.     Dim xDATE As Range, i, Rng As Range
  4.     Dim D As Object, K, X As Long, Ar As Variant
  5.     Set xDATE = Sheets("Attendance Report").[J3]  '輸入報表首日之前1日日期 的儲存格
  6.     With Sheets("data")  '資料工作表
  7.         Set Rng = .[D4] '資料開使的儲存格
  8.         X = 0
  9.         Do While Rng <> ""
  10.             Set D = CreateObject("SCRIPTING.DICTIONARY")  '設立變數 :字典物件
  11.             i = 1
  12.             Do While Rng.Offset(i - 1) = Rng  'Employee  上下列相同
  13.                 With Rng.Offset(i - 1)
  14.                     If D.EXISTS(.Range("C1").Value) Then    '如果在 Dictionary 物件中指定的關鍵字存在,傳回 True,
  15.                         D(.Range("C1").Value) = D(.Range("C1").Value) & "," & .Range("D1").Text
  16.                     Else
  17.                         D(.Range("C1").Value) = .Range("D1").Text
  18.                         '.Range("C1").Value 為日期值
  19.                     End If
  20.                  End With
  21.                 i = i + 1
  22.             Loop
  23.             For Each K In D.KEYS  'Keys 方法 傳回一個陣列,該陣列包含一個 Dictionary 物件中的全部既存的的關鍵字。
  24.                 Ar = Split(D(K), ",") 'Keys的內容
  25.                 With xDATE.Offset(, K - xDATE)  'k 為日期值
  26.                     .Parent.Cells(.Row + X + 1, "a") = Rng.Range("b1").Value
  27.                     .Parent.Cells(.Row + X + 1, "d").Resize(20) = Rng
  28.                     If UBound(Ar) = 1 Then
  29.                         .Cells(X + 3) = Ar(0)
  30.                         .Cells(X + 4) = Ar(1)
  31.                     ElseIf UBound(Ar) = 2 Then
  32.                         .Cells(X + 3) = Ar(0)
  33.                         .Cells(X + 4) = Ar(2)
  34.                         .Cells(X + 10) = Ar(1)
  35.                     ElseIf UBound(Ar) = 3 Then
  36.                         .Cells(X + 3) = Ar(0)
  37.                         .Cells(X + 4) = Ar(3)
  38.                         .Cells(X + 10) = Ar(1)
  39.                         .Cells(X + 11) = Ar(2)
  40.                     ElseIf UBound(Ar) = 4 Then
  41.                         .Cells(X + 3) = Ar(0)
  42.                         .Cells(X + 4) = Ar(4)
  43.                         .Cells(X + 10) = Ar(1)
  44.                         .Cells(X + 11) = Ar(2)
  45.                     End If
  46.                 End With
  47.             Next
  48.             X = X + 20
  49.             Set Rng = Rng.Offset(i)
  50.         Loop
  51.     End With
  52. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 12# lpk187

是呀, 用函數令FILE運作很慢才用VBA, 感謝細心的增值:'(

TOP

        靜思自在 : 有智慧才能分辨善惡邪正;有謙虛才能建立美滿人生。
返回列表 上一主題