如何用VBA查找增加和减少的名单

小绿草 · 发表于 2018-7-14 21:22

请老师帮忙找出增加和减少的学生名单。详见附件。

jiminyanyan · 发表于 2018-7-14 21:25

同一个学生，学籍号不变吧？

小绿草 · 发表于 2018-7-14 21:26

是。。。。。。。。

小绿草 · 发表于 2018-7-14 21:31

是的，同一个学生，学籍号在任何年段都不变。

jiminyanyan · 发表于 2018-7-14 21:32

小绿草发表于 2018-7-14 21:31
是的，同一个学生，学籍号在任何年段都不变。

http://club.excelhome.net/thread-1143188-1-1.html

chxw68 · 发表于 2018-7-14 21:41

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("上学期名单")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:f" & r)
For i = 1 To UBound(arr)
d(arr(i, 1)) = i
Next
End With
With Worksheets("下学期名单")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
brr = .Range("a3:f" & r)
ReDim drr(1 To UBound(brr), 1 To UBound(brr, 2))
m = 0
For i = 1 To UBound(brr)
If Not d.exists(brr(i, 1)) Then
m = m + 1
For j = 1 To UBound(brr, 2)
drr(m, j) = brr(i, j)
Next
Else
d.Remove (brr(i, 1))
End If
Next
End With
tt = d.items
If d.Count > 0 Then
ReDim crr(1 To d.Count, 1 To UBound(arr, 2))
n = 0
For Each aa In d.items
n = n + 1
For j = 1 To UBound(arr, 2)
crr(n, j) = arr(aa, j)
Next
Next
End If
With Worksheets("增减名单")
.Cells.Clear
If m > 0 Then
With .Range("a1")
.Value = "增加名单"
.Resize(1, 6).Merge
With .Font
.Name = "黑体"
.Size = 16
End With
End With
.Range("a2").Resize(1, 6) = Array("学籍辅号", "班级", "座号", "姓名", "电话", "家长姓名")
.Range("a3").Resize(m, UBound(drr, 2)) = drr
.Range("a2").Resize(m + 1, UBound(drr, 2)).Borders.LineStyle = xlContinuous
End If
r = .Cells(.Rows.Count, 1).End(xlUp).Row
If r > 1 Then
r = r + 2
End If
If n > 0 Then
With .Cells(r, 1)
.Value = "减少名单"
.Resize(1, 6).Merge
With .Font
.Name = "黑体"
.Size = 16
End With
End With
.Cells(r + 1, 1).Resize(1, 6) = Array("学籍辅号", "班级", "座号", "姓名", "电话", "家长姓名")
.Cells(r + 2, 1).Resize(n, UBound(crr, 2)) = crr
.Cells(r + 1, 1).Resize(n + 1, UBound(crr, 2)).Borders.LineStyle = xlContinuous
End If
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-7-14 21:42

详见附件。

chxw68 · 发表于 2018-7-14 21:52

Sub test2()
Dim r%, i%
Dim arr(), brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
vs = [{"上学期名单","下学期名单"}]
ReDim arr(1 To UBound(vs))
For k = 1 To UBound(vs)
With Worksheets(vs(k))
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr(k) = .Range("a3:f" & r)
For i = 1 To UBound(arr(k))
If Not d.exists(arr(k)(i, 1)) Then
Set d(arr(k)(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(k)(i, 1))(k) = i
Next
End With
Next
ReDim brr(1 To UBound(arr(1)), 1 To UBound(arr(1), 2))
ReDim crr(1 To UBound(arr(2)), 1 To UBound(arr(2), 2))
m = 0
n = 0
For Each aa In d.keys
If d(aa).Count = 1 Then
If d(aa).exists(1) Then
m = m + 1
x = d(aa)(1)
For j = 1 To UBound(arr(1), 2)
brr(m, j) = arr(1)(x, j)
Next
ElseIf d(aa).exists(2) Then
n = n + 1
x = d(aa)(2)
For j = 1 To UBound(arr(2), 2)
crr(n, j) = arr(2)(x, j)
Next
End If
End If
Next
With Worksheets("增减名单")
.Cells.Clear
If m > 0 Then
With .Range("a1")
.Value = "减少名单"
.Resize(1, 6).Merge
With .Font
.Name = "黑体"
.Size = 16
End With
End With
.Range("a2").Resize(1, 6) = Array("学籍辅号", "班级", "座号", "姓名", "电话", "家长姓名")
.Range("a3").Resize(m, UBound(brr, 2)) = brr
.Range("a2").Resize(m + 1, UBound(brr, 2)).Borders.LineStyle = xlContinuous
End If
r = .Cells(.Rows.Count, 1).End(xlUp).Row
If r > 1 Then
r = r + 2
End If
If n > 0 Then
With .Cells(r, 1)
.Value = "增加名单"
.Resize(1, 6).Merge
With .Font
.Name = "黑体"
.Size = 16
End With
End With
.Cells(r + 1, 1).Resize(1, 6) = Array("学籍辅号", "班级", "座号", "姓名", "电话", "家长姓名")
.Cells(r + 2, 1).Resize(n, UBound(crr, 2)) = crr
.Cells(r + 1, 1).Resize(n + 1, UBound(crr, 2)).Borders.LineStyle = xlContinuous
End If
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2018-7-14 21:53

两种解法。

小绿草 · 发表于 2018-7-14 22:03

chxw68 发表于 2018-7-14 21:42
详见附件。

老师，您写的代码运行得非常快，非常感谢您。想不到您这么快就写出代码，技术实在高明，再次感谢。

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

[求助] 如何用VBA查找增加和减少的名单

评分

评分

评分