|
思路的问题 在个人查询中，执行宏1 无法判断初一或初二等 干脆分三个子程序，初1初2初3? Dim mypath
Sub 查询个人()
t1 = UserForm查询窗体.CheckBox1.Value 'TextBox1
t2 = UserForm查询窗体.CheckBox2.Value 'TextBox1 要注意指向窗体
t3 = UserForm查询窗体.CheckBox3.Value
If t1 = True And t2 = False And t3 = False Then
t = UserForm查询窗体.CheckBox1.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
Call 初1
End If
If t2 = True And t1 = False And t3 = False Then
t = UserForm查询窗体.CheckBox2.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
Call 初2
End If
If t3 = True And t1 = False And t2 = False Then
t = UserForm查询窗体.CheckBox3.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
Call 初3
End If
End Sub Sub 初1()
Dim arr, brr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wj = Dir(mypath & "*.xls*")
Worksheets(1).Range("b3:c3").ClearContents
Worksheets(1).Range("a4:c10000").ClearContents
arr = Worksheets(1).Range("a1:v3")
s = [{"数学","2";"语文","3"}]
Do While wj <> ""
If wj <> ThisWorkbook.Name Then
With Workbooks.Open(mypath & wj)
For n = 1 To UBound(s)
If InStr(wj, s(n, 1)) Then
j = s(n, 2)
End If
Next
brr = .Sheets(.Sheets.Count).UsedRange
ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
For i = 1 To UBound(brr)
d(brr(i, ncm)) = i
Next
For i = 1 To UBound(arr)
xm = Trim(UserForm查询窗体.TextBox1.Text)
If xm <> "" Then
If d.Exists(xm) Then
m = d(xm)
arr(3, 1) = xm
arr(3, j) = brr(m, ncm + 2)
Else
arr(3, j) = "/"
End If
End If
Next
d.RemoveAll
.Close 0
End With
End If
wj = Dir
Loop
Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
Columns("A:G").AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheet4.Activate
Selection.Merge
Range("A1:A2").Merge 'A1：A2合并 [A1].Value = "姓名"
[B1].Value = "数学"
[C1].Value = "语文"
Dim t As Integer
For t = 2 To 3
Cells(2, t).Value = "剩余课时" '用循环赋值“剩余课时”
With Cells(2, t).Font '设置单元格格式
.Name = "宋体"
.FontStyle = "bold"
.Size = 12 '字体大小
.ColorIndex = 12 '字体颜色
End With
Next
ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框
With Selection
ActiveSheet.UsedRange.HorizontalAlignment = xlRight '对已用区域左对齐
End With
End Sub
Sub 初2()
Dim arr, brr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wj = Dir(mypath & "*.xls*")
Worksheets(1).Range("b3:e3").ClearContents
Worksheets(1).Range("a4:e10000").ClearContents
arr = Worksheets(1).Range("a1:e3")
s = [{"数学","2";"物理","3";"英语","4";"语文","5"}]
Do While wj <> ""
If wj <> ThisWorkbook.Name Then
With Workbooks.Open(mypath & wj)
For n = 1 To UBound(s)
If InStr(wj, s(n, 1)) Then
j = s(n, 2)
End If
Next
brr = .Sheets(.Sheets.Count).UsedRange
ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
For i = 1 To UBound(brr)
d(brr(i, ncm)) = i
Next
For i = 1 To UBound(arr)
xm = Trim(UserForm查询窗体.TextBox1.Text)
If xm <> "" Then
If d.Exists(xm) Then
m = d(xm)
arr(3, 1) = xm
arr(3, j) = brr(m, ncm + 2)
Else
arr(3, j) = "/"
End If
End If
Next
d.RemoveAll
.Close 0
End With
End If
wj = Dir
Loop
Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
Columns("A:G").AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheet4.Activate
Selection.Merge
Range("A1:A2").Merge 'A1：A2合并
[A1].Value = "姓名"
[B1].Value = "数学"
[C1].Value = "物理"
[D1].Value = "英语"
[E1].Value = "语文" Dim t As Integer
For t = 2 To 5
Cells(2, t).Value = "剩余课时" '用循环赋值“剩余课时”
With Cells(2, t).Font '设置单元格格式
.Name = "宋体"
.FontStyle = "bold"
.Size = 12 '字体大小
.ColorIndex = 12 '字体颜色
End With
Next
ActiveSheet.UsedRange.Borders.LineStyle = 1 '对已用区域添加边框
With Selection
ActiveSheet.UsedRange.HorizontalAlignment = xlRight '对已用区域左对齐
End With
End Sub Sub 初3()
Dim arr, brr, d, i&, j%
Set d = CreateObject("scripting.dictionary")
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wj = Dir(mypath & "*.xls*")
Worksheets(1).Range("b3:g3").ClearContents
Worksheets(1).Range("a4:g10000").ClearContents
arr = Worksheets(1).Range("a1:g3")
s = [{"数学","2";"物理","3";"英语","4";"语文","5";"历史","6";"化学","7"}]
Do While wj <> ""
If wj <> ThisWorkbook.Name Then
With Workbooks.Open(mypath & wj)
For n = 1 To UBound(s)
If InStr(wj, s(n, 1)) Then
j = s(n, 2)
End If
Next
brr = .Sheets(.Sheets.Count).UsedRange
ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
For i = 1 To UBound(brr)
d(brr(i, ncm)) = i
Next
For i = 1 To UBound(arr)
xm = Trim(UserForm查询窗体.TextBox1.Text)
If xm <> "" Then
If d.Exists(xm) Then
m = d(xm)
arr(3, 1) = xm
arr(3, j) = brr(m, ncm + 2)
Else
arr(3, j) = "/"
End If
End If
Next
d.RemoveAll
.Close 0
End With
End If
wj = Dir
Loop
Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
Columns("A:G").AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheet4.Activate
'Call 合并单元格指定位置
'Call 写入单元格课时查询
'Call 复制
'Call 边框线
Call 抬头目录 '组合了上面4个模块
End Sub |