请教一个表格转换的问题

jiminyanyan · 发表于 2014-5-16 20:23

请教一个表格转换的问题

chxw68 · 发表于 2014-5-16 20:31

Sub test()
Dim d As Object
Dim r%, i%
Dim arr, brr()
Set d = CreateObject("scripting.dictionary")
With Worksheets("人员信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:d" & r)
For i = 1 To UBound(arr)
If arr(i, 4) > 41 Then
If Not d.Exists(arr(i, 2)) Then
d(arr(i, 2)) = i
Else
If arr(i, 4) > arr(d(arr(i, 2)), 4) Then
d(arr(i, 2)) = i
End If
End If
End If
Next
End With
ReDim brr(1 To d.Count, 1 To 4)
m = 0
For Each ii In d.Items
m = m + 1
For j = 1 To 4
brr(m, j) = arr(ii, j)
Next
Next
With Worksheets("人员信息")
.Range("h2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2014-5-16 20:31

参见附件。

jiminyanyan · 发表于 2014-5-16 20:41

Sub test()
Dim d As Object
Dim r%, i%, n%
Dim arr, brr(1 To 1000, 1 To 4)
Set d = CreateObject("scripting.dictionary")
With Worksheets("人员信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:d" & r)
For i = 2 To UBound(arr)
If arr(i, 4) > 41 Then
If d.Exists(arr(i, 2)) Then
If arr(i, 4) > brr(d(arr(i, 2)), 4) Then
brr(d(arr(i, 2)), 4) = arr(i, 4)
End If
Else
n = n + 1
d(arr(i, 2)) = n
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(i, 3)
brr(n, 4) = arr(i, 4)
End If
End If
Next
.Range("h2:k1000").ClearContents
.Range("h2").Resize(n, 4) = brr
End With
End Sub

复制代码

jiminyanyan · 发表于 2014-5-16 20:43

我自己也写了一个，和2楼老师的差不多。。。。

yaozong · 发表于 2014-5-16 20:44

本帖最后由 yaozong 于 2014-5-16 20:50 编辑

已考虑到，不同学校同名，或同名性别不同（用：“学校+姓名+性别” 作字段统计）

Sub Test()
  Dim d, arr, s$, i&, j&, m&
  Set d = CreateObject("Scripting.Dictionary")
  arr = [a1].CurrentRegion
  ReDim brr(1 To UBound(arr), 1 To 4)
  For i = 1 To UBound(arr)
If arr(i, 4) > 41 Then
   s = arr(i, 1) & arr(i, 2) & arr(i, 3)
   If Not d.exists(s) Then
      m = m + 1
      d(s) = m
      For j = 1 To 4
      brr(m, j) = arr(i, j)
      Next
   Else
      If brr(d(s), 4) < arr(i, 4) Then brr(d(s), 4) = arr(i, 4)
   End If
End If
  Next
  [h1].Resize(m, 4) = brr
  Set d = Nothing
End Sub

chxw68 · 发表于 2014-5-16 20:46

提供一个ADO+SQL版本的：

Sub test2()
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sql As String
Dim mybook As String
mybook = ThisWorkbook.FullName
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
.Open
End With
sql = "select first(学校名称),first(姓名),first(性别),first(分数) from (select * from [人员信息$a1:d] where 分数>41 order by 分数 desc) group by 姓名"
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
With Worksheets("人员信息")
.Range("h2").CopyFromRecordset rs
End With
End Sub

复制代码

chxw68 · 发表于 2014-5-16 20:47

详见附件。

jiminyanyan · 发表于 2014-5-16 20:55

1。左图转换成右图
2 分数低于41的删除
3.名字一样的，只保留分数高的那个。。
4.做完后再做个拆分工作簿。
---------------------------------------
做完后我想再做一下第四步。。。

Sub test()
Dim d As Object
Dim r%, i%
Dim arr, brr()
Set d = CreateObject("scripting.dictionary")
With Worksheets("人员信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:d" & r)
For i = 1 To UBound(arr)
If arr(i, 4) > 41 Then
If Not d.Exists(arr(i, 2)) Then
d(arr(i, 2)) = i
Else
If arr(i, 4) > arr(d(arr(i, 2)), 4) Then
d(arr(i, 2)) = i
End If
End If
End If
Next
End With
ReDim brr(1 To d.Count, 1 To 4)
m = 0
For Each ii In d.Items
m = m + 1
For j = 1 To 4
brr(m, j) = arr(ii, j)
Next
Next
With Worksheets("Sheet2")
.Range("a1:d1") = Array("学校名称", "姓名", "性别", "分数")
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
Sheet2.Activate
拆分工作簿
Sheet1.Activate
End Sub
Sub 拆分工作簿()
Dim arr, brr, d As Object, k, t, a, i&, j&, m&, l&, sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
arr = [a2].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) & "," & i
Next
k = d.Keys
t = d.Items
brr = arr
Set sh = ActiveSheet
For i = 0 To d.Count - 1
m = 1
a = Split(t(i), ",")
For j = 1 To UBound(a)
m = m + 1
For l = 1 To UBound(arr, 2)
brr(m, l) = arr(a(j), l)
Next
Next
sh.Copy
With ActiveWorkbook
.Sheets(1).UsedRange.Offset(m).Clear
.Sheets(1).[a1].Resize(m, UBound(arr, 2)) = brr
.SaveAs ThisWorkbook.Path & "" & k(i) & ".xls"
.Close
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

dajiahaoxinku12 · 发表于 2014-5-16 21:23

Sub 统计()
arr = [a2:d20]
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
      If d.exists(arr(i, 2)) Then
         m = d(arr(i, 2))
         If d(arr(m, 2)) > arr(m, 2) Then
            brr(m, 4) = arr(i, 4)
         End If
      Else
         If arr(i, 4) <= 41 Then GoTo 100
            k = k + 1
            d(arr(i, 2)) = k
            brr(k, 1) = arr(i, 1)
            brr(k, 2) = arr(i, 2)
            brr(k, 3) = arr(i, 3)
            brr(k, 4) = arr(i, 4)
      End If
100:
Next
Range("h1:k1") = Range("a1:d1").Value
Range("h2").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

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

[求助] 请教一个表格转换的问题

评分

点评

评分

评分