[已解决]求助能否修改一下代码加多在F列提取K列的数全在一起生成。谢谢

qinhuan66

求助能否修改一下代码加多在F列提取K列的数全在一起生成。谢谢
生成试室座位.rar (23.82 KB, 下载次数: 6)

2013-6-11 20:58 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-11 21:54

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrTemp()
   
3.     Dim i As Long, j As Long
   
4.     Dim lLastRow As Long
   
5.     Dim arrNO, lNO As Long
   
6. 
   
7.     arr = CheckInput
   
8.     If Not IsArray(arr) Then Exit Sub
   
9.     i = Cells(Rows.Count, "k").End(xlUp).Row
   
10.     arrNO = Range("k3:k" & i).Value
    
11.    
    
12.     Application.ScreenUpdating = False
    
13.     Application.DisplayAlerts = False
    
14.     Application.EnableEvents = False
    
15.     Columns("d:f").ClearContents
    
16.     Range("d2").Resize(, 3) = Array("试室号", "座位号", "准考证号")
    
17. 
    
18.     For i = 1 To UBound(arr)
    
19.         If Len(arr(i, 1)) Then
    
20.             lLastRow = Cells(Rows.Count, "d").End(xlUp).Row + 1
    
21.             ReDim arrTemp(1 To arr(i, 2), 1 To 3)
    
22.             For j = 1 To arr(i, 2)
    
23.                 lNO = lNO + 1
    
24.                 arrTemp(j, 1) = Format(Val(arr(i, 1)), "'00")
    
25.                 arrTemp(j, 2) = Format(j, "'00")
    
26.                 arrTemp(j, 3) = Replace(arrNO(lNO, 1) & arrTemp(j, 1) & arrTemp(j, 2), "'", "")
    
27.                
    
28.             Next
    
29.             Cells(lLastRow, "d").Resize(arr(i, 2), UBound(arrTemp, 2)).Value = arrTemp
    
30.         Else
    
31.             Exit For
    
32.         End If
    
33.     Next
    
34. 
    
35.     Application.ScreenUpdating = True
    
36.     Application.DisplayAlerts = True
    
37.     Application.EnableEvents = True
    
38. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

什么情况，看不明白。

hwc2ycy

F列直接公式下拉就OK了。

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrTemp()
   
3.     Dim i As Long, j As Long
   
4.     Dim lLastRow As Long
   
5. 
   
6.     arr = CheckInput
   
7.     If Not IsArray(arr) Then Exit Sub
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.     Application.EnableEvents = False
    
11.     Columns("d:f").ClearContents
    
12.     Range("d2").Resize(, 2) = Array("试室号", "座位号", "准考证号")
    
13. 
    
14.     For i = 1 To UBound(arr)
    
15.         If Len(arr(i, 1)) Then
    
16.             lLastRow = Cells(Rows.Count, "d").End(xlUp).Row + 1
    
17.             ReDim arrTemp(1 To arr(i, 2), 1 To 2)
    
18.             For j = 1 To arr(i, 2)
    
19.                 arrTemp(j, 1) = Format(Val(arr(i, 1)), "'00")
    
20.                 arrTemp(j, 2) = Format(j, "'00")
    
21.             Next
    
22.             Cells(lLastRow, "d").Resize(arr(i, 2), 2).Value = arrTemp
    
23.         Else
    
24.             Exit For
    
25.         End If
    
26.     Next
    
27. 
    
28.     lLastRow = Cells(Rows.Count, "d").End(xlUp).Row - 2
    
29.     If lLastRow > 0 Then
    
30.         With Range("f3")
    
31.             .FormulaR1C1Local = "=RC[5]&RC[-2]&RC[-1]"
    
32.             If lLastRow > 1 Then
    
33.                 .AutoFill .Resize(lLastRow), xlFillDefault
    
34.             End If
    
35.         End With
    
36.     End If
    
37.     Application.ScreenUpdating = True
    
38.     Application.DisplayAlerts = True
    
39.     Application.EnableEvents = True
    
40. End Sub

复制代码

qinhuan66

hwc2ycy 发表于 2013-6-11 21:30
F列直接公式下拉就OK了。

老师我现在是用函数的
=IF($D3="","",K3&D3&E3)
但是我觉得用函数的东西打开工作薄时运行公式太多数据时很慢。谢谢

我的意思想生成每个人的准考证号码，准考证号是根据试室号和座位号来生成。
比如一个人的准考证号是10位数字：（2013450102即是2013为固定的年份45是随机生成的数字01是试室号02是座位号）

hwc2ycy

呵呵。

hwc2ycy

这个也可以改的。

qinhuan66

hwc2ycy 发表于 2013-6-11 21:38

老师真不道怎么谢谢您好。写得真好。我就是有个遗憾就是我那个生成随机数据如果能根据A1单元（姓名）有值才生成就更加完美了。谢谢。

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, arrTemp()
   
3.     Dim i As Long, j As Long
   
4.     Dim lLastRow As Long
   
5.     Dim arrNO, lNO As Long
   
6. 
   
7.     arr = CheckInput
   
8.     If Not IsArray(arr) Then Exit Sub
   
9.     i = Cells(Rows.Count, "k").End(xlUp).Row
   
10.     arrNO = Range("k3:k" & i).Value
    
11.    
    
12.     Application.ScreenUpdating = False
    
13.     Application.DisplayAlerts = False
    
14.     Application.EnableEvents = False
    
15.     Columns("d:f").ClearContents
    
16.     Range("d2").Resize(, 3) = Array("试室号", "座位号", "准考证号")
    
17. 
    
18.     For i = 1 To UBound(arr)
    
19.         If Len(arr(i, 1)) Then
    
20.             lLastRow = Cells(Rows.Count, "d").End(xlUp).Row + 1
    
21.             ReDim arrTemp(1 To arr(i, 2), 1 To 3)
    
22.             For j = 1 To arr(i, 2)
    
23.                 lNO = lNO + 1
    
24.                 arrTemp(j, 1) = Format(Val(arr(i, 1)), "'00")
    
25.                 arrTemp(j, 2) = Format(j, "'00")
    
26.                 arrTemp(j, 3) = Replace(arrNO(lNO, 1) & arrTemp(j, 1) & arrTemp(j, 2), "'", "")
    
27.                
    
28.             Next
    
29.             Cells(lLastRow, "d").Resize(arr(i, 2), UBound(arrTemp, 2)).Value = arrTemp
    
30.         Else
    
31.             Exit For
    
32.         End If
    
33.     Next
    
34. 
    
35.     Application.ScreenUpdating = True
    
36.     Application.DisplayAlerts = True
    
37.     Application.EnableEvents = True
    
38. End Sub

复制代码