[已解决]碰上一个高难度的问题，自动生成房号

船夫

求助，我们公司让用VBA做一个程序，可以按照需要自动生成一些数据，比如说，若设置楼幢数为5，则自动生成5个工作表并分别命名1号楼、2号楼……5号楼，然后每幢楼设置几层、几个单元、每单元几户后自动生上面这个格式，房号中1－代表1号楼、1－1－代表1号楼一单元、1－1－101代表1号楼一单元01户，我的这个表是29层1个单元四户的，如果是两个单元，就需要在右边再加四户，这个用VBA该怎么做啊？

最佳答案

月排行榜 / 总排行榜

suye1010

2013-1-15 20:06

1. Option Explicit
   
2. 
   
3. Sub GenNo()
   
4. Dim Bs As Integer, Dep As Integer, Floors As Integer, H As Integer, i As Integer, j As Integer, k As Integer, arr, WB As Workbook, sh As Worksheet
   
5. Bs = Range("B1")
   
6. Dep = Range("B2")
   
7. Floors = Range("B3")
   
8. H = Range("B4")
   
9. ReDim arr(1 To Floors + 2, 1 To Dep * H * 5)
   
10. Set WB = Workbooks.Add
    
11. For i = 1 To Bs
    
12.     For j = 1 To Dep * H
    
13.         arr(1, j * 5 - 4) = IIf(j Mod H, j Mod H, H)
    
14.         arr(2, j * 5 - 4) = "房号"
    
15.         arr(2, j * 5 - 3) = "附加价格位"
    
16.         arr(2, j * 5 - 2) = "单位"
    
17.         arr(2, j * 5 - 1) = "面积"
    
18.         arr(2, j * 5) = "总价"
    
19.         For k = Floors To 1 Step -1
    
20.             arr(Floors - k + 3, j * 5 - 4) = "'" & i & "-" & (j - 1) \ H + 1 & "-" & k & Format(IIf(j Mod H, j Mod H, H), "00")
    
21.         Next k
    
22.     Next j
    
23.     With WB.Sheets.Add(, Sheets(Sheets.Count))
    
24.         .Name = i & "号楼"
    
25.         With .Range("A1:E" & UBound(arr))
    
26.             .HorizontalAlignment = xlCenter
    
27.             .Borders(xlInsideVertical).LineStyle = xlContinuous
    
28.             .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    
29.             With .Borders(xlEdgeTop)
    
30.                 .LineStyle = xlContinuous
    
31.                 .Weight = xlMedium
    
32.             End With
    
33.             With .Borders(xlEdgeBottom)
    
34.                 .LineStyle = xlContinuous
    
35.                 .Weight = xlMedium
    
36.             End With
    
37.             With .Borders(xlEdgeRight)
    
38.                 .LineStyle = xlContinuous
    
39.                 .Weight = xlMedium
    
40.             End With
    
41.             .Range("A1:E1").HorizontalAlignment = xlCenterAcrossSelection
    
42.             .Copy
    
43.         End With
    
44.         With .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2))
    
45.             .Value = arr
    
46.             .PasteSpecial Paste:=xlPasteFormats
    
47.         End With
    
48.         Application.CutCopyMode = False
    
49.     End With
    
50. Next i
    
51. Application.DisplayAlerts = False
    
52. For Each sh In WB.Sheets
    
53.     If sh.Cells(1, 1) = "" Then sh.Delete
    
54. Next
    
55. Application.DisplayAlerts = True
    
56. End Sub
    

复制代码

求助，自动生成房号.zip (18.06 KB, 下载次数: 6, 售价: 1 个金币)

2013-1-15 20:06 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Option Explicit
   
2. 
   
3. Sub GenNo()
   
4. Dim Bs As Integer, Dep As Integer, Floors As Integer, H As Integer, i As Integer, j As Integer, k As Integer, arr, WB As Workbook, sh As Worksheet
   
5. Bs = Range("B1")
   
6. Dep = Range("B2")
   
7. Floors = Range("B3")
   
8. H = Range("B4")
   
9. ReDim arr(1 To Floors + 2, 1 To Dep * H * 5)
   
10. Set WB = Workbooks.Add
    
11. For i = 1 To Bs
    
12.     For j = 1 To Dep * H
    
13.         arr(1, j * 5 - 4) = IIf(j Mod H, j Mod H, H)
    
14.         arr(2, j * 5 - 4) = "房号"
    
15.         arr(2, j * 5 - 3) = "附加价格位"
    
16.         arr(2, j * 5 - 2) = "单位"
    
17.         arr(2, j * 5 - 1) = "面积"
    
18.         arr(2, j * 5) = "总价"
    
19.         For k = Floors To 1 Step -1
    
20.             arr(Floors - k + 3, j * 5 - 4) = "'" & i & "-" & (j - 1) \ H + 1 & "-" & k & Format(IIf(j Mod H, j Mod H, H), "00")
    
21.         Next k
    
22.     Next j
    
23.     With WB.Sheets.Add(, Sheets(Sheets.Count))
    
24.         .Name = i & "号楼"
    
25.         With .Range("A1:E" & UBound(arr))
    
26.             .HorizontalAlignment = xlCenter
    
27.             .Borders(xlInsideVertical).LineStyle = xlContinuous
    
28.             .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    
29.             With .Borders(xlEdgeTop)
    
30.                 .LineStyle = xlContinuous
    
31.                 .Weight = xlMedium
    
32.             End With
    
33.             With .Borders(xlEdgeBottom)
    
34.                 .LineStyle = xlContinuous
    
35.                 .Weight = xlMedium
    
36.             End With
    
37.             With .Borders(xlEdgeRight)
    
38.                 .LineStyle = xlContinuous
    
39.                 .Weight = xlMedium
    
40.             End With
    
41.             .Range("A1:E1").HorizontalAlignment = xlCenterAcrossSelection
    
42.             .Copy
    
43.         End With
    
44.         With .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2))
    
45.             .Value = arr
    
46.             .PasteSpecial Paste:=xlPasteFormats
    
47.         End With
    
48.         Application.CutCopyMode = False
    
49.     End With
    
50. Next i
    
51. Application.DisplayAlerts = False
    
52. For Each sh In WB.Sheets
    
53.     If sh.Cells(1, 1) = "" Then sh.Delete
    
54. Next
    
55. Application.DisplayAlerts = True
    
56. End Sub
    

复制代码

求助，自动生成房号.zip (18.06 KB, 下载次数: 6, 售价: 1 个金币)

2013-1-15 20:06 上传

点击文件名下载附件

船夫

老师您真神了，十分感谢十分感谢，正是我要的样子，老师能帮我解释一下代码吗？我想好好学习一下，无论如何真是太谢谢你了