|
|
楼主 |
发表于 2013-4-12 15:23
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 lzqlaj 于 2013-4-12 15:47 编辑
网盘广告和本人无关，代码公布如下：
Public bjls As Integer
Private Sub ComboBox1_Change()
On Error Resume Next
Dim zmhs, k
If ComboBox1.Value <> "" Then
Sheets(ComboBox2.Value).Select
zmhs = Sheets(ComboBox2.Value).Range("a65536").End(xlUp).Row
If ComboBox1.Value > 1 Then TextBox1.Value = Cells(ComboBox1.Value - 1, 1)
For k = ComboBox1.Value To zmhs
If WorksheetFunction.CountA(Rows(k + 1)) = 0 And WorksheetFunction.CountA(Rows(k)) <> 0 Then
TextBox3.Value = k: Exit For
End If
Next k
End If
End Sub
Private Sub ComboBox2_Change()
On Error Resume Next
Dim sht, hs, ls, q, i, TheArray As Variant
If ComboBox2.Value <> "" Then
Sheets(ComboBox2.Value).Select
TextBox3.Value = Sheets(ComboBox2.Value).Range("a65536").End(xlUp).Row
End If
If OptionButton1 = True Then TextBox3.Locked = True
sht = ComboBox2.Value
hs = Sheets(sht).Cells(65536, 1).End(xlUp).Row
ls = Sheets(sht).Range("IV" & ComboBox1.Value).End(xlToLeft).Column
If ComboBox2.Value > 0 Then
For q = 1 To ls
If Sheets(sht).Cells(ComboBox1.Value, q).Text = "班级" Then
bjls = q
Dim arr1, d As Object
Set d = CreateObject("scripting.dictionary")
arr1 = Sheets(sht).Range(Sheets(sht).Cells(ComboBox1.Value + 1, bjls), Sheets(sht).Cells(hs, bjls))
For i = 1 To UBound(arr1)
If Not d.exists(arr1(i, 1)) Then d.Add arr1(i, 1), ""
Next i
End If
Next q
ComboBox3.Clear
TheArray = d.keys
SelectionSort TheArray
For i = 0 To UBound(TheArray)
ComboBox3.AddItem TheArray(i)
Next i
ComboBox3.AddItem "全部"
End If
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub CommandButton4_Click()
Application.ScreenUpdating = False
Dim bm As String
Dim cjtcolumn As Integer
Dim sj, arr, xrows, shtSheet, j, i, k, chd, x, xh, shname, sh, brr, w, k1, g, gs, crr, drr
sj = TextBox2.Value
On Error GoTo end1
bm = Sheets(ComboBox2.Value).Name
xrows = Sheets(bm).Cells(65536, bjls).End(xlUp).Row
If ComboBox1.Value = "" Then MsgBox "未填写标题行行号！": Exit Sub
cjtcolumn = Sheets(bm).Cells(ComboBox1.Value, 256).End(xlToLeft).Column
brr = Sheets(bm).Range(Cells(ComboBox1.Value, 1), Cells(xrows, cjtcolumn))
shname = ComboBox2.Value & "成绩条"
For Each sh In Sheets
If sh.Name = shname Then
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next
ReDim arr(1 To UBound(brr), 1 To UBound(brr, 2))
If ComboBox3.Value = "" Then MsgBox "未选择班级！": Exit Sub
If ComboBox3.Value <> "全部" Then
w = 2
For g = 1 To UBound(brr, 2)
arr(1, g) = brr(1, g)
Next g
For k1 = 2 To UBound(brr)
If brr(k1, bjls) = ComboBox3.Text Then
For g = 1 To UBound(brr, 2)
arr(w, g) = brr(k1, g)
Next g
w = w + 1
End If
Next k1
gs = w - 1
Else
arr = brr
gs = UBound(brr)
End If
Set shtSheet = Sheets.Add(After:=ActiveSheet)
shtSheet.Name = ComboBox2.Value & "成绩条"
Cells.Select
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Selection.Font.Name = "宋体"
Selection.Font.Size = 14
成绩条.Hide
进度条.Show 0
ReDim crr(1 To 7, 1 To UBound(arr, 2))
crr(1, 1) = TextBox1.Value
For g = 1 To UBound(brr, 2)
crr(3, g) = arr(1, g)
Next g
crr(5, UBound(crr, 2) - 3) = "家长签字:"
chd = Len(gs - 1 - 1)
For i = 1 To gs - 1
drr = crr
xh = i
If Len(i) < chd Then
For x = 1 To chd - Len(i)
xh = "0" & xh
Next x
End If
drr(2, 1) = sj & " NO." & xh
For k = 1 To UBound(arr, 2)
drr(4, k) = arr(i + 1, k)
Next k
Cells(7 * (i - 1) + 1, 1).Resize(7, UBound(drr, 2)) = drr
Range(Cells(7 * (i - 1) + 1, 1), Cells(7 * (i - 1) + 1, UBound(drr, 2))).Select
Selection.Merge
With Selection.Font
.Name = "宋体"
.FontStyle = "粗体"
.Size = 18
End With
Range(Cells(7 * (i - 1) + 2, 1), Cells(7 * (i - 1) + 2, UBound(drr, 2))).Select
Selection.Merge
Selection.HorizontalAlignment = xlRight
Range(Cells(7 * (i - 1) + 3, 1), Cells(7 * (i - 1) + 4, UBound(drr, 2))).Borders.LineStyle = xlContinuous
Range(Cells(7 * (i - 1) + 5, UBound(drr, 2) - 3), Cells(7 * (i - 1) + 6, UBound(drr, 2) - 1)).Select
With Selection
.HorizontalAlignment = xlGeneral
.MergeCells = True
End With
Range(Cells(7 * (i - 1) + 6, 1), Cells(7 * (i - 1) + 6, UBound(drr, 2))).Select
Selection.Borders(xlEdgeBottom).LineStyle = xlDot
Rows(7 * (i - 1) + 7).RowHeight = Rows("1").RowHeight * 0.5
j = CStr(Int(i / (gs - 1) * 16))
进度条.TextBox2 = CStr(Int(i / (gs - 1) * 100)) & "%"
DoEvents
With 进度条.TextBox1
.Value = Application.WorksheetFunction.Rept("n", j)
.Font.Name = "Wingdings"
.ForeColor = &HFF0000
.Font.Size = 18
End With
Next i
Erase arr, brr, crr, drr
Columns("A:IV").Columns.AutoFit
进度条.Label1.Caption = "制作成绩条已完成,点击关闭......"
进度条.Label1.ForeColor = &HFF&
Unload Me
end1: Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Dim i As Integer
For i = 1 To 4
ComboBox1.AddItem i
Next i
ComboBox1.Value = 2
TextBox1.Value = "二中考试成绩条"
TextBox2.Value = Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日"
For i = 1 To Sheets.count
ComboBox2.AddItem Sheets(i).Name
Next i
ComboBox2.Value = ActiveSheet.Name
End Sub
Function SelectionSort(TempArray As Variant)
Dim MaxVal As Variant
Dim MaxIndex As Integer
Dim i, j As Integer
For i = UBound(TempArray) To 1 Step -1
MaxVal = TempArray(i)
MaxIndex = i
For j = 1 To i
If TempArray(j) > MaxVal Then
MaxVal = TempArray(j)
MaxIndex = j
End If
Next j
If MaxIndex < i Then
TempArray(MaxIndex) = TempArray(i)
TempArray(i) = MaxVal
End If
Next i
End Function
Sub SelectionSortMyArray()
Dim TheArray As Variant
TheArray = Array("one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten")
SelectionSort TheArray
For i = 1 To UBound(TheArray)
MsgBox TheArray(i)
Next i
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2013-4-12 14:42
