Excel VBA問題

zxcnny930

各位好
最近因为要考试
所以打算自己制作Excel题库来随机出题
但是有些答案有ABCDEFGH
大部分的答案却只有ABCDE
这段代码我该如何修改让VBA判断FGH如果是空白就不填入

[Visual Basic] 纯文本查看 复制代码

Sub start70()
  Dim randans(8) As String
  Dim blank(3000) As Integer
  
  '先檢查答案的格式是否有誤
  If Worksheets("題庫").Cells(2, 3) <> "" Then
    If Not checkans Then
      Exit Sub
    End If
  End If
  
  '完成判斷後會，qn代表題目數量。
  qn = 2
  Do While Worksheets("題庫").Cells(qn, 1) <> ""
    qn = qn + 1
  Loop
  qn = qn - 2
  
  '判斷題目數量是否少於20題。
  If qn < 20 Then
    MsgBox ("題庫題目少於20題，請增加題目。")
    Exit Sub
  End If
  
  '開始亂數排列所有題目。
  
  For i = 1 To 3000
    blank(i) = i + 1
  Next

  For i = 1 To 2 * qn
    a = Application.WorksheetFunction.RandBetween(1, qn)
    b = Application.WorksheetFunction.RandBetween(1, qn)
    temp = blank(a): blank(a) = blank(b): blank(b) = temp
  Next
  
  '開始製作試卷
  ans = ""
  For i = 1 To 70
    '寫入題號
    Worksheets("70題試卷").Cells(i + 2, 2) = i & "、"
    
    '寫入試題(選擇題)
    If Worksheets("題庫").Cells(2, 3) <> "" Then 'blank(i)
    
      '要亂數調換答案
      
      Select Case Worksheets("題庫").Cells(blank(i), 2)
        Case "A"
          randans(1) = "T" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
        Case "B"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "T" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
        Case "C"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "T" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
        Case "D"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "T" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
          Case "E"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "T" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
          Case "F"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "T" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
          Case "G"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "T" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "F" & Worksheets("題庫").Cells(blank(i), 10)
          Case "H"
          randans(1) = "F" & Worksheets("題庫").Cells(blank(i), 3)
          randans(2) = "F" & Worksheets("題庫").Cells(blank(i), 4)
          randans(3) = "F" & Worksheets("題庫").Cells(blank(i), 5)
          randans(4) = "F" & Worksheets("題庫").Cells(blank(i), 6)
          randans(5) = "F" & Worksheets("題庫").Cells(blank(i), 7)
          randans(6) = "F" & Worksheets("題庫").Cells(blank(i), 8)
          randans(7) = "F" & Worksheets("題庫").Cells(blank(i), 9)
          randans(8) = "T" & Worksheets("題庫").Cells(blank(i), 10)
          
      End Select
        
      '將四個選項亂調
      For j = 1 To 10
        a = Application.WorksheetFunction.RandBetween(1, 8)
        b = Application.WorksheetFunction.RandBetween(1, 8)
        temp = randans(a): randans(a) = randans(b): randans(b) = temp
      Next
        
      '開始寫入題目
      Worksheets("70題試卷").Cells(i + 2, 3) = Worksheets("題庫").Cells(blank(i), 1) & _
                                           vbCrLf + " (A)" & Right(randans(1), Len(randans(1)) - 1) & _
                                           " (B)" & Right(randans(2), Len(randans(2)) - 1) & _
                                           " (C)" & Right(randans(3), Len(randans(3)) - 1) & _
                                           " (D)" & Right(randans(4), Len(randans(4)) - 1) & _
                                           " (E)" & Right(randans(5), Len(randans(5)) - 1) & _
                                           " (F)" & Right(randans(6), Len(randans(6)) - 1) & _
                                           " (G)" & Right(randans(7), Len(randans(7)) - 1) & _
                                           " (H)" & Right(randans(8), Len(randans(8)) - 1)
      '開始寫入答案
      If Left(randans(1), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "A"
      End If
      If Left(randans(2), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "B"
      End If
      If Left(randans(3), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "C"
      End If
      If Left(randans(4), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "D"
      End If
      If Left(randans(5), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "E"
      End If
        If Left(randans(6), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "F"
      End If
        If Left(randans(7), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "G"
      End If
        If Left(randans(8), 1) = "T" Then
        Worksheets("70題試卷").Cells(i + 2, 8) = i & "、" & "J"
      End If
      
    Else
      '表示這是填空題
      Worksheets("20題試卷").Cells(i + 2, 3) = Worksheets("題庫").Cells(blank(i), 1)
      '收集各題的答案
      Worksheets("20題試卷").Cells(i + 2, 8) = i & "、" & Worksheets("題庫").Cells(blank(i), 2)
    End If
    
    '依據題目字數大小設定字形大小
    Select Case LenB(Worksheets("70題試卷").Cells(i + 2, 3))
      Case Is <= 9999999
        Worksheets("70題試卷").Cells(i + 2, 3).Font.Size = 10

    End Select
      
  Next

End Sub

miocaro507

已经更新完毕，请到以下链接查看。

链接：https://pan.baidu.com/s/1tRJYmanZFhfSi8L0_CoxdQ
提取码：u2c9

注：
1. 只对20题试卷做了修改
2. 为便于测试，把题库做了适当修改，某些题目增加了选项五、选项六
3. 代码中做了繁体注释，凡是做了修改的地方，一般都加了2020/03/30，但不知道能否正常显示

zhlezhi

能不能分享一些vba 的实际应用的代码，便于数据的整理迁移复制之类？

jlzjf

非常感谢

zhanglei1371

vba的问题最好去Excelhome论坛

feichedang_caj

路过,帮楼主顶贴了.

miocaro507

可否提供源文件？

kai-memory

建议FGH为空的时候指定特殊字段，出题输出后遇到这个就不print，没有看到原文件有些东西不好判断

川黔

解决问题 得发你得vba附件 以及相关得例题库 不然谁知道你得界面是如何设计得  如何去读写得

头狼

弄好后请分享一下，我也想弄个自己出题组卷的VBA，工作上有需要