|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim mypath$, myname$
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim d As Object
- Dim reg As New RegExp
- With reg
- .Global = True
- .Pattern = "^([1-9]|1[0-2])月份(工资册|台账)\.xlsx$"
- End With
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*.xlsx")
- Set d = CreateObject("scripting.dictionary")
- Do While myname <> ""
- If reg.test(myname) Then
- Set mh = reg.Execute(myname)
- yf = mh(0).SubMatches(0)
- lx = mh(0).SubMatches(1)
- Set wb = GetObject(mypath & myname)
- With wb
- If lx = "工资册" Then
- With .Worksheets(1)
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:c" & r)
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 1)) Then
- ReDim brr(1 To 15)
- brr(2) = arr(i, 1)
- brr(3) = arr(i, 2)
- Else
- brr = d(arr(i, 1))
- End If
- brr(yf + 5) = arr(i, 3)
- d(arr(i, 1)) = brr
- Next
- End With
- Else
- k = 0
- For Each ws In .Worksheets(Array("社保", "公积金"))
- k = k + 1
- With ws
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:c" & r)
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 1)) Then
- ReDim brr(1 To 15)
- brr(2) = arr(i, 1)
- brr(3) = arr(i, 2)
- Else
- brr = d(arr(i, 1))
- End If
- If k = 1 Then
- n = 8 + yf
- Else
- n = 11 + yf
- End If
- brr(n) = arr(i, 3)
- d(arr(i, 1)) = brr
- Next
- End With
- Next
- End If
- .Close False
- End With
- End If
- myname = Dir
- Loop
- With Worksheets("例子所要的结果")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- arr = .Range("b1:b" & r)
- For i = 5 To UBound(arr)
- If d.exists(arr(i, 1)) Then
- brr = d(arr(i, 1))
- .Cells(i, 1).Resize(1, UBound(brr)) = brr
- End If
- Next
- End With
- End Sub
复制代码 |
|