各路大侠，高手帮我看看这个程序哪里出了问题，不能运行

lyxzjp

VBA.rar (41.73 KB, 下载次数: 0)

2015-10-7 17:40 上传

点击文件名下载附件

这些代码主要实现的功能如下：
1.随着第六行中数值(假设数值为n，n<=12)的变化，下方的编号也跟着变化，变化规律为CW01~CWn+1,LW01~LWn,如果第五行中为T的话就多加1个FW01.
2.把生成的编号变为1列，放在单元格Q列中，第五行中的段号也对应的变成1列放置在P列，长度数值也对应着变为1列放置在R列。
3.将以上第二点中生成的数据，按照单元格J2的要求重复填充到工作表“数据录入”中，同时每次重复填充工作表“数据录入”中C列的套编号也跟着变化。
4.套编号的前缀“EN”有C4单元格来控制。
具体详见附件。感谢大侠们的帮助！
附件复制按钮不运行，不知道是为什么。且将附件中的编号变成一列时有重复，不知道为啥，大侠看看如何调整
Sub 编号()
Dim i, k, j, m, s As Integer
With Sheets("工程信息录入")
Union(.Range("D7:D5000"), .Range("F7:F5000"), .Range("H7:H5000"), .Range("J7:J5000"), .Range("L7:L5000"), .Range("N7:N5000")).ClearContents
For i = 4 To 15 Step 2
For k = 1 To .Cells(6, i).Value + 1
.Cells(Rows.Count, i).End(xlUp).Offset(1) = "CW" & Format(k, "00")
Next k
For j = 1 To .Cells(6, i).Value

.Cells(Rows.Count, i).End(xlUp).Offset(1) = "LW" & Format(j, "00")

Next j
If .Cells(5, i) = "T" Then .Cells(Rows.Count, i).End(xlUp).Offset(1) = "FW01"

If .Cells(5, i) = "T" Then

s = .Cells(6, i) + 1 + .Cells(6, i) + 1
Else
s = .Cells(6, i) + 1 + .Cells(6, i)
End If
For m = 1 To s
.Range(.Cells(5, i).Address).Copy .Cells(Rows.Count, "p").End(xlUp).Offset(1)

Next m

.Range(.Cells(7, i), .Cells(.Cells(Rows.Count, i).End(xlUp).Row, i)).Copy .Cells(Rows.Count, "Q").End(xlUp).Offset(1)
Next
End With
End Sub
Sub 复制到数据录入()
Dim x, y As Integer
Sheets("数据录入").Range("c3:e65533").ClearContents
y = Sheets("工程信息录入").Cells(Rows.Count, "p").End(xlUp).Row

For x = 1 To Sheets("工程信息录入").Range("j2")

Sheets("工程信息录入").Range("p2:q" & y).Copy Sheets("数据录入").Cells(Rows.Count, 4).End(xlUp).Offset(1)
For y = 1 To Sheets("工程信息录入").Cells(Rows.Count, "p").End(xlUp).Row - 1
Sheets("数据录入").Cells(Rows.Count, 3).End(xlUp).Offset(1) = Sheets("工程信息录入").Range("c4") & Format(x, "00")
Next
Next
End Sub

fjmxwrs

无附件，写越多，越看不明白，上附件加说明是硬道理

lyxzjp

VBA.rar (41.73 KB, 下载次数: 1)

2015-10-7 17:40 上传

点击文件名下载附件