按照条件由1表生成2表

sxdmsz · 发表于 2024-5-7 11:22

从1表把所有学生的I、J、K、L列成绩相加，并按照组合从高到低排序得到2表。谢谢。

2.rar (89.8 KB, 下载次数: 22)

cnmlgb9998 · 发表于 2024-5-7 12:33

PQ 方案。。。。。。。。。。。。。。

taller · 发表于 2024-5-7 12:43

Option Explicit
Sub SqlDemo()
Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
PathStr = ThisWorkbook.FullName '路径
Select Case Application.Version * 1
Case Is <= 11
conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
Case Is >= 12
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
End Select
strSQL = "select '' as 序号, 姓名, 班级, 组合2, '' as 名次, total as [4选2总分] from (select 姓名, 班级, RIGHT(组合, 2) as 组合2, iif(化原 is null, 0, 化原)+iif(生原 is null, 0, 生原)+iif(政原 is null, 0, 政原)+iif(地原 is null, 0, 地原) as total From ['1$']) order by total desc"
rst.Open strSQL, conn, 1, 1
Set sht = Worksheets.Add(ActiveSheet)
With sht
For i = 0 To rst.Fields.Count - 1
.Cells(1, i + 1) = rst.Fields(i).Name
Next i
.Range("a2").CopyFromRecordset rst
With .Range("B2", .Range("B2").End(xlDown)).Offset(, -1)
.Formula = "=Row()-1"
.Value = .Value
.Offset(, 4).Value = .Value
End With
End With
rst.Close: conn.Close: Set conn = Nothing: Set rst = Nothing
End Sub

复制代码

yaofengda · 发表于 2024-5-7 12:43

taller · 发表于 2024-5-7 13:16

baofa2 · 发表于 2024-5-7 13:25

Sub test1() '纯个人练习
Dim data, i As Long, j As Long, pos As Long, col As Long
With Worksheets("1").Range("A1").CurrentRegion
data = Range(.Cells(1), .Offset(1)).Value
End With
col = 3
For j = 0 To 2
col = col + 1
data(1, col) = Split("组合2 名次 4选2总分")(j)
Next
For i = 2 To UBound(data) - 1
For j = 4 To col
data(i, j) = ""
Next
For j = 9 To 12
If Val(data(i, j)) Then
data(i, col) = Val(data(i, col)) + Val(data(i, j))
data(i, 4) = data(i, 4) & Left(data(1, j), 1)
End If
Next
Next
pos = 1
QuickSort data, pos + 1, UBound(data) - 1, 1, col, 4, False
For i = pos + 1 To UBound(data) - 1
If data(i, 4) <> data(i + 1, 4) Then
QuickSort data, pos + 1, i, 1, col, col, True
CustomRank data, pos + 1, i, 6, 5, False
pos = i
End If
Next
With Worksheets("2").Range("A1")
.CurrentRegion.Clear 'Contents
With .Resize(UBound(data) - 1, col)
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.Font.Name = "宋体"
.Font.Size = 12
.Value = data
End With
End With
Beep
End Sub
Function CustomRank(ar, upper As Long, lower As Long, src As Long, dst As Long, Optional CHI As Boolean = False)
Dim i As Long, rank_ As Long
rank_ = 1
ar(upper, dst) = 1
For i = upper + 1 To lower
If Not CHI Then
rank_ = rank_ + 1
Else '(ChineseStyle)
If ar(i, src) <> ar(i - 1, src) Then rank_ = rank_ + 1
End If
If ar(i, src) <> ar(i - 1, src) Then
ar(i, dst) = rank_
Else
ar(i, dst) = ar(i - 1, dst)
End If
Next
End Function
Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pCol As Long, Optional Flag As Boolean = True)
Dim t As Long, b As Long, x As Long, pivot, swap
t = u
b = d
pivot = ar((u + d) \ 2, pCol)
While t <= b
If Flag Then 'Order by number DESC
Do
If ar(t, pCol) > pivot Then t = t + 1 Else Exit Do
Loop While t < d
Do
If ar(b, pCol) < pivot Then b = b - 1 Else Exit Do
Loop While b > u
Else 'Order by text ASC
Do
If StrComp(ar(t, pCol), pivot, vbTextCompare) = -1 Then t = t + 1 Else Exit Do
Loop While t < d 'vbTextCompare 1 vbBinaryCompare 0
Do
If StrComp(pivot, ar(b, pCol), vbTextCompare) = -1 Then b = b - 1 Else Exit Do
Loop While b > u
End If
If t < b Then
For x = l To r
swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
Next
t = t + 1: b = b - 1
Else
If t = b Then t = t + 1: b = b - 1
End If
Wend
If t < d Then QuickSort ar, t, d, l, r, pCol, Flag
If b > u Then QuickSort ar, u, b, l, r, pCol, Flag
End Function

复制代码

ykcbf1100 · 发表于 2024-5-7 13:40

附件供参考。。。

ykcbf1100 · 发表于 2024-5-7 13:40

参与一下。。。

Sub ykcbf() '//2024.5.7
With Sheets("1")
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 13)
End With
ReDim brr(1 To r, 1 To 6)
For i = 2 To UBound(arr)
m = m + 1
For j = 1 To 3
brr(m, j) = arr(i, j)
Next
brr(m, 4) = Mid(arr(i, 13), 2)
brr(m, 6) = arr(i, 9) + arr(i, 10) + arr(i, 11) + arr(i, 12)
Next
With Sheets("2")
.UsedRange.Offset(1).Clear
.[a2].Resize(m, 6) = brr
Set Rng = .[b2].Resize(m, 5)
Rng.Sort key1:=.[d2], order1:=1, key2:=.[f2], order2:=2, Header:=2
For i = 2 To m + 1
If .Cells(i, 4) = .Cells(i + 1, 4) Then
n = n + 1
.Cells(i, 5) = n
Else
.Cells(i, 5) = n + 1
n = 0
End If
Next
With .[a2].Resize(m, 6)
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
MsgBox "OK！"
End Sub

复制代码

沈默00 · 发表于 2024-5-7 13:59

沈默00 · 发表于 2024-5-7 14:02

参与一下....

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

[求助] 按照条件由1表生成2表

评分

评分

评分

评分

浏览过的版块