VBA实战营招生考试题（考试结束）

兰色幻想 · 发表于 2012-8-14 19:56

本帖最后由兰色幻想于 2012-8-16 08:58 编辑

      本试题即是VBA实战营招生考试题目，也是VBA学习小组毕业考试题目。共3个大题。
               循环题20分
               自定义函数60分
               VBA数组题目20分
      题目下载：

VBA实战营考试题.rar (9.3 KB, 下载次数: 398)

askteller · 发表于 2012-8-14 20:13

本帖最后由 askteller 于 2012-8-14 23:07 编辑

Sub 第一题()
Dim i, irow, a
irow = [A65536].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 Sub

复制代码

Function 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

复制代码

只记得贴代友，差点忘记上传附件了，现补上。

VBA实战营考试题_askteller.rar (21.73 KB, 下载次数: 38)

hrpotter · 发表于 2012-8-14 20:59

C12:hrpotter

Sub 循环题()
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

复制代码

C12-hrpotter-VBA实战营考试题.rar (20.11 KB, 下载次数: 33)

gmclast · 发表于 2012-8-14 21:10

作业在模块中，请批改，谢谢

zjcat35 · 发表于 2012-8-14 21:37

本帖最后由 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-14 21:41

本帖最后由 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

复制代码

hwc2ycy · 发表于 2012-8-14 21:41

只会做循环题了。

VBA实战营考试题-hwc2ycy.rar (12.07 KB, 下载次数: 18)

rebornxldeng · 发表于 2012-8-14 21:53

本帖最后由 rebornxldeng 于 2012-8-15 10:08 编辑

只做出来第1题和第3题... ...先交吧.能拿的BB先拿到是原则.
第2题... ...觉得EXCEL自带的函数够用了.所有一直忽略了对它的学习.

无聊的疯子 · 发表于 2012-8-14 22:03

谢谢校长放宽时间！

无聊的疯子_VBA实战营考试题.zip (23.9 KB, 下载次数: 27)

tsigms · 发表于 2012-8-14 22:07

希望能通过考试#￥￥%￥%

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

[练习题] VBA实战营招生考试题（考试结束）

相关帖子

点评

点评

点评

评分

点评

点评

评分

点评

点评