VBA实战营招生考试题（考试结束）
本帖最后由 兰色幻想 于 2012-8-16 08:58 编辑本试题即是VBA实战营招生考试题目，也是VBA学习小组毕业考试题目。共3个大题。
循环题20分
自定义函数60分
VBA数组题目20分
题目下载：
注意：
1、因为时间比较充裕，还可以查资料。所以同学们一定要独立完成。如果发现雷同答案，两个试卷成绩同时取消。另外本次考试并不是进入VBA特训营的唯一条件，所以你即使作弊通过了也不一定能进。大家还是试一下自已的真实本领吧。
2、交卷方式。
题目做完后，请务必在本贴后跟贴上交，把带答案的表格提交上来。本贴设置为仅作者可见，其他同学无法看到你的答案。在截止日之前可以重新编辑作业。上交到其他贴或单独开贴的无效。
3、截止时间：
考虑到今晚有的同学有事无法上网，所以上交试卷时间截止到明天（8月15日）中午12点。
本帖最后由 askteller 于 2012-8-14 23:07 编辑
Sub 第一题()
Dim i, irow, a
irow = .End(3).Row
'On Error Resume Next
For i = 2 To irow
If Cells(i, 2) + Cells(i + 1, 2) + Cells(i + 2, 2) + Cells(i + 3, 2) + Cells(i + 4, 2) > 14 Then
Range("A" & i & ":B" & i + 4).Interior.ColorIndex = 6
i = i + 6
End If
Next i
End Sub
Sub 第三题()
Dim arr()
Dim myst
arr = Array(13, 2, 3, 4, 6, 7, 8, 9, 22, 32)
arr(4) = arr(4) & "|" & "100"
myst = Join(arr, "|")
arr = Array(Split(myst, "|"))
End SubFunction Wlookup(a As Range, b As Range, c As Integer, Optional d As Integer = 0) '第二题
Application.Volatile
Dim arr()
Dim i, j, m, n, irow, icolumn
arr = b
irow = b.Row: icolumn = b.Column
If c > 0 Then
j = c - 1
Else
j = c
End If
If d = 0 Then
For i = 1 To UBound(arr)
If a = arr(i, 1) Then
m = i + irow - 1
Exit For
End If
Next i
Wlookup = Cells(m, icolumn).Offset(0, j)
ElseIf d = -1 Then
For i = UBound(arr) To 1 Step -1
If a = arr(i, 1) Then
m = i + irow - 1
Exit For
End If
Next i
Wlookup = Cells(m, icolumn).Offset(0, j)
ElseIf d > 0 Then
For i = 1 To UBound(arr)
If a = arr(i, 1) Then
m = i + irow - 1
n = n + 1
If n = d Then
Wlookup = Cells(m, icolumn).Offset(0, j)
Exit For
Else: Wlookup = "不存在"
End If
End If
Next i
Else
Wlookup = "不存在"
End If
If VarType(Wlookup) = 7 Then Wlookup = Format(Wlookup, "yyyy-m-d")
End Function只记得贴代友，差点忘记上传附件了，现补上。
C12:hrpotterSub 循环题()
Dim i As Long
With Sheets("循环题")
.Cells.Interior.ColorIndex = xlNone
For i = 2 To .Range("a65536").End(xlUp).Row - 4
If Application.Sum(.Cells(i, 2).Resize(5, 1)) > 14 Then
.Cells(i, 1).Resize(5, 2).Interior.ColorIndex = 6
i = i + 4
End If
Next
End With
End Sub
Function wlookup(findtext As Variant, rng As Range, m As Integer, Optional n As Integer = 0)
Dim arr()
Dim i As Long, j As Long
Dim rg As Range
On Error GoTo line
For Each rg In rng
If findtext = rg.Value Then
i = i + 1
ReDim Preserve arr(1 To i)
If m <= 0 Then
arr(i) = rg.Offset(0, m)
Else
arr(i) = rg.Offset(0, m - 1)
End If
End If
Next
If n = 0 Then
j = 1
ElseIf n = -1 Then
j = UBound(arr)
Else
j = n
End If
If VBA.IsDate(arr(j)) Then
wlookup = Format(arr(j), "yyyy-m-d")
Else
wlookup = arr(j)
End If
Exit Function
line:
wlookup = "不存在"
End Function
Sub 数组题()
Dim arr, i As Integer, j As Integer
With Sheets("数组题")
arr = Array(13, 2, 3, 4, 6, 7, 8, 9, 22, 32)
i = 5
j = 100
.Cells.Clear
.Range("a1").Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
.Rows(i + 1).Insert
.Cells(i + 1, 1) = j
arr = Application.Transpose(.Range("a1:a" & UBound(arr) + 2)) '结果
.Cells.Clear
End With
End Sub 作业在模块中，请批改，谢谢 本帖最后由 zjcat35 于 2012-8-15 09:33 编辑
第一题Sub 第一题()
Dim i%
For i = 6 To Cells(Rows.Count, 2).End(3).Row
If Application.Sum(Range("b" & i - 4 & ":b" & i)) > 14 Then
Cells(i - 4, 1).Resize(5, 2).Interior.ColorIndex = 6
i = i + 5
End If
Next i
End Sub第二题Function WLOOKUP(rg As Range, rng As Range, i%, Optional j%)
Dim arr, k%, brr, m%
brr = rng
If rng.Column + i < 1 Or i > rng.Columns.Count Then WLOOKUP = "不存在": Exit Function
If i <= 0 Then
arr = rng.Offset(, i).Resize(, 1)
Else
arr = rng.Offset(, i - 1).Resize(, 1)
End If
If j = -1 Then
For k = UBound(brr) To 1 Step -1
If rg.Value = brr(k, 1) Then
If IsDate(arr(k, 1)) Then
WLOOKUP = Format(arr(k, 1), "yyyy-m-d")
Else
WLOOKUP = arr(k, 1)
End If
Exit Function
End If
Next k
WLOOKUP = "不存在"
ElseIf j > -1 Then
For k = 1 To UBound(brr)
If rg.Value = brr(k, 1) Then
m = m + 1
If m >= j Then
If IsDate(arr(k, 1)) Then
WLOOKUP = Format(arr(k, 1), "yyyy-m-d")
Else
WLOOKUP = arr(k, 1)
End If
Exit Function
End If
End If
Next k
WLOOKUP = "不存在"
Else
WLOOKUP = "不存在"
End If
End Function第三题Sub 第三题()
Dim arr, str$
arr = Array(13, 2, 3, 4, 6, 7, 8, 9, 22, 32)
str = Join(arr, ",")
str = Application.Substitute(str, ",", ",100,", 5)
arr = Split(str, ",")
End Sub 本帖最后由 jonnygu 于 2012-8-15 08:36 编辑
第一题Sub 循环题()
Dim i As Long, x As Long, y As Long, n As Long, m As Integer
For i = 2 To Range("a65536").End(3).Row
n = 0
n = n + Application.Sum(Range("b" & i + m * 5 - m & ":b" & i + m * 5 - m + 4))
If n > 14 Then Range("a" & i + m * 5 - m & ":b" & i + m * 5 - m + 4).Interior.ColorIndex = 6: m = m + 1
Next i
End Sub
第二题Function Wlookup(rng, rng1 As Range, Optional n As Integer, Optional y As Integer)
Dim arr, brr, x As Long, i As Long
brr = rng1
If n < 0 Then n = n + 1
arr = rng1.Offset(0, n - 1)
For i = 1 To UBound(brr)
If brr(i, 1) = rng Then x = x + 1
If y = 0 Then y = 1
If y = x Then Wlookup = IIf(IsDate(arr(i, 1)), Format(arr(i, 1), "yyyy-m-d"), arr(i, 1)): Exit Function
If y = -1 And brr(i, 1) = rng Then Wlookup = IIf(IsDate(arr(i, 1)), Format(arr(i, 1), "yyyy-m-d"), arr(i, 1))
Next
If y <> -1 And Wlookup = 0 Then Wlookup = "不存在"
End Function
第三题Sub 数组题()
Dim arr, istring As String
arr = Array(13, 2, 3, 4, 6, 7, 8, 9, 22, 32)
istring = Join(arr, "@")
istring = Application.WorksheetFunction.Substitute(istring, "@", "@100@", 5)
arr = Split(istring, "@")
End Sub 只会做循环题了。
本帖最后由 rebornxldeng 于 2012-8-15 10:08 编辑
只做出来第1题和第3题... ...先交吧.能拿的BB先拿到是原则.
第2题... ...觉得EXCEL自带的函数够用了.所有一直忽略了对它的学习.
谢谢校长放宽时间！
希望能通过考试#￥￥%￥%