数据量较大的两个工作表比较

s1j2p3 · 发表于 2014-1-13 14:39

希望用vba代码来完成，将工资表和社保表进行比较。

chxw68 · 发表于 2014-1-13 15:22

Sub 生成社保表()
Dim d As New Dictionary
Dim arr, brr()
Dim r%, i%
With Worksheets("数据源")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:k" & r)
End With
ReDim brr(1 To 16, 1 To 1)
m = 0
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 2)) Then
m = m + 1
ReDim Preserve brr(1 To 16, 1 To m)
brr(2, m) = arr(i, 2)
brr(3, m) = arr(i, 3)
brr(4, m) = arr(i, 5)
d(arr(i, 2)) = m
End If
n = d(arr(i, 2))
Select Case arr(i, 1)
Case "城镇职工基本医疗保险"
brr(6, n) = arr(i, 6)
brr(12, n) = arr(i, 9)
Case "大病医疗救助"
brr(14, n) = arr(i, 9)
Case "工伤保险"
brr(8, n) = arr(i, 6)
Case "企业基本养老保险"
brr(5, n) = arr(i, 6)
brr(11, n) = arr(i, 9)
Case "生育保险"
brr(9, n) = arr(i, 6)
Case "失业保险"
brr(7, n) = arr(i, 6)
brr(13, n) = arr(i, 9)
End Select
Next
brr = Application.Transpose(brr)
For i = 1 To UBound(brr)
brr(i, 1) = i
For j = 5 To 9
brr(i, 10) = brr(i, 10) + brr(i, j)
Next
For j = 11 To 14
brr(i, 15) = brr(i, 15) + brr(i, j)
Next
brr(i, 16) = brr(i, 10) + brr(i, 15)
Next
With Worksheets("社保表")
.UsedRange.Offset(2, 0).Delete
.Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
.Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub

复制代码

liulang0808 · 发表于 2014-1-13 15:33

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
a1 = Sheets("社保表").Cells(Rows.Count, 1).End(3).Row
a2 = Sheets("工资表").Cells(Rows.Count, 1).End(3).Row
Sheets("工资表").Range("a2:b" & a2).Copy Cells(2, 1)
Sheets("工资表").Range("e2:e" & a2).Copy
Cells(2, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
For j = 2 To Cells(Rows.Count, 1).End(3).Row
      Set rng = Sheets("社保表").Columns(2).Find(Cells(j, 1), lookat:=xlWhole)
      If rng Is Nothing Then
      Else
         Cells(j, 3) = Cells(j, 3) - Sheets("社保表").Cells(rng.Row, "p")
      End If
Next j
For j = 7 To a1
      If Columns(1).Find(Sheets("社保表").Cells(j, 2), lookat:=xlWhole) Is Nothing Then
         a2 = a2 + 1
         Cells(a2, 1) = Sheets("社保表").Cells(j, 2)
         Cells(a2, 2) = Sheets("社保表").Cells(j, 3)
         Cells(a2, 3) = 0 - Sheets("社保表").Cells(j, "p")
      End If
Next j
For j = 2 To Cells(Rows.Count, 1).End(3).Row
      If Cells(j, 3) > 1 Then
         Cells(j, 4) = "未缴"
      Else
         If Cells(j, 3) > 0 Then
            Cells(j, 4) = "正常缴费"
         Else

            Cells(j, 4) = "未扣"
         End If
      End If
Next j
Application.ScreenUpdating = True
End Sub

liulang0808 · 发表于 2014-1-13 15:34

你看看那附件是否是你需要的

chxw68 · 发表于 2014-1-13 15:43

Sub 找差异()
Dim d As New Dictionary
Dim r%, i%
Dim arr, brr()
With Worksheets("社保表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:p" & r)
End With
m = 0
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 2)) Then
m = m + 1
ReDim Preserve brr(1 To 4, 1 To m)
d(arr(i, 2)) = m
End If
n = d(arr(i, 2))
brr(1, n) = arr(i, 2)
brr(2, n) = arr(i, 3)
brr(3, n) = arr(i, 16)
Next
With Worksheets("工资表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
End With
For i = 1 To UBound(arr)
If d.Exists(arr(i, 1)) Then
n = d(arr(i, 1))
brr(3, n) = arr(i, 5) - brr(3, n)
d.Remove (arr(i, 1))
Else
m = m + 1
ReDim Preserve brr(1 To 4, 1 To m)
brr(1, m) = arr(i, 1)
brr(2, m) = arr(i, 2)
brr(3, m) = arr(i, 5)
brr(4, m) = "未缴"
End If
Next
If d.Count > 0 Then
For Each aa In d.Keys
n = d(aa)
brr(4, n) = "未扣"
Next
End If
brr = Application.Transpose(brr)
For i = 1 To UBound(brr)
If brr(i, 3) < 0.00001 Then brr(i, 4) = "正常缴费"
Next
With Worksheets("差异")
.UsedRange.Offset(1, 0).ClearContents
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2014-1-13 15:45

参见附件。

LMY123 · 发表于 2018-7-25 10:23

字典与FIND比较两表

		自动登录	找回密码
密码			免费注册

[求助] 数据量较大的两个工作表比较