[已解决]考勤VBA學習中求助

happymary2

考勤表 20150815.rar (109.15 KB, 下载次数: 6)

2015-8-15 17:27 上传

点击文件名下载附件

一直在學習VBA但總有阻礙, 已爬文很多但仍未明白, 下列是考勤表的試作, 我參考了一些書, 但想是錯了, 故求教:

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

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2015-8-16 10:01

1. Sub lqxs()
   
2. Dim Arr, i&, Sht As Worksheet, Brr, r%, Arr1()
   
3. Dim d, k, t, ks, js, j&, x$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set Sht = ActiveSheet
   
6. [j4:bz5000].ClearContents
   
7. Brr = Sht.UsedRange
   
8. Arr = Sheets("data").UsedRange
   
9. For i = 4 To UBound(Arr)
   
10.     d(Arr(i, 9)) = d(Arr(i, 9)) & Arr(i, 7) & ","
    
11. Next
    
12. For i = 4 To UBound(Brr)
    
13.     If Brr(i, 9) = "上班時間" Then
    
14.         r = r + 1
    
15.         ReDim Preserve Arr1(1 To r)
    
16.         Arr1(r) = i
    
17.     End If
    
18. Next
    
19. k = Array(0, 1, 7, 8)
    
20. For i = 1 To r
    
21.     If i <> r Then
    
22.         js = Arr1(i + 1) - 1
    
23.     Else
    
24.         js = UBound(Brr)
    
25.     End If
    
26.     ks = Arr1(i): bh = Brr(ks, 1)
    
27.     For j = 10 To UBound(Brr, 2)
    
28.         x = bh & Format(Brr(3, j), "d/m/yyyy")
    
29.         If d.exists(x) Then
    
30.             t = d(x)
    
31.             t = Left(t, Len(t) - 1)
    
32.             If InStr(t, ",") Then
    
33.                 aa = Split(t, ",")
    
34.                 Brr(ks, j) = aa(0): Brr(ks + 1, j) = aa(UBound(aa))
    
35.                 If UBound(aa) > 2 Then
    
36.                 Brr(ks + 7, j) = aa(1): Brr(ks + 8, j) = aa(2)
    
37.                 End If
    
38.             Else
    
39.                 Brr(ks, j) = t
    
40.             End If
    
41.         End If
    
42.     Next
    
43. Next
    
44. [a1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
45. End Sub
    

复制代码

跳转到最佳答案楼层

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Sht As Worksheet, Brr, r%, Arr1()
   
3. Dim d, k, t, ks, js, j&, x$
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set Sht = ActiveSheet
   
6. [j4:bz5000].ClearContents
   
7. Brr = Sht.UsedRange
   
8. Arr = Sheets("data").UsedRange
   
9. For i = 4 To UBound(Arr)
   
10.     d(Arr(i, 9)) = d(Arr(i, 9)) & Arr(i, 7) & ","
    
11. Next
    
12. For i = 4 To UBound(Brr)
    
13.     If Brr(i, 9) = "上班時間" Then
    
14.         r = r + 1
    
15.         ReDim Preserve Arr1(1 To r)
    
16.         Arr1(r) = i
    
17.     End If
    
18. Next
    
19. k = Array(0, 1, 7, 8)
    
20. For i = 1 To r
    
21.     If i <> r Then
    
22.         js = Arr1(i + 1) - 1
    
23.     Else
    
24.         js = UBound(Brr)
    
25.     End If
    
26.     ks = Arr1(i): bh = Brr(ks, 1)
    
27.     For j = 10 To UBound(Brr, 2)
    
28.         x = bh & Format(Brr(3, j), "d/m/yyyy")
    
29.         If d.exists(x) Then
    
30.             t = d(x)
    
31.             t = Left(t, Len(t) - 1)
    
32.             If InStr(t, ",") Then
    
33.                 aa = Split(t, ",")
    
34.                 Brr(ks, j) = aa(0): Brr(ks + 1, j) = aa(UBound(aa))
    
35.                 If UBound(aa) > 2 Then
    
36.                 Brr(ks + 7, j) = aa(1): Brr(ks + 8, j) = aa(2)
    
37.                 End If
    
38.             Else
    
39.                 Brr(ks, j) = t
    
40.             End If
    
41.         End If
    
42.     Next
    
43. Next
    
44. [a1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
45. End Sub
    

复制代码

happymary2

蓝桥玄霜 发表于 2015-8-16 10:01

感謝賜教!