请守柔版主帮忙优化代码！

xiangdhai

要将表1的数据转换为表三的数据。所编代码如下，可运行时总不能达到预期效果，请帮忙修正。图表见附件。

Dim j As Integer Dim K As Integer Dim L As Integer Sub 转换数据() Application.ScreenUpdating = False '关闭执行程序时发生的屏幕更新，加快运行速度。 Sheets("Sheet1").Select iCount = Sheets("Sheet1").[A1].CurrentRegion.Rows.Count For j = 1 To iCount Rows(j).Select Sheets("Sheet3").Cells(1, 1) = Cells(j, 1) Sheets("Sheet3").Cells(1, 2) = Cells(j, 2) Sheets("Sheet3").Cells(1, 3) = Cells(j, 3) Sheets("Sheet3").Cells(1, 4) = Cells(j, 4) Sheets("Sheet3").Cells(1, 5) = Cells(j + 1, 1) Sheets("Sheet3").Cells(1, 6) = Cells(j + 1, 2) Sheets("Sheet3").Cells(1, 7) = Cells(j + 1, 3) Sheets("Sheet3").Cells(1, 8) = Cells(j + 1, 4) Sheets("Sheet3").Cells(1, 9) = Cells(j + 2, 1) Sheets("Sheet3").Cells(1, 10) = Cells(j + 2, 2) Sheets("Sheet3").Cells(1, 11) = Cells(j + 2, 3) Sheets("Sheet3").Cells(1, 12) = Cells(j + 2, 4) Sheets("Sheet3").Select L = WorksheetFunction.Count(Range("A1:A1000")) '假设转换后数据行数为1000，该值可变化。 Range(Cells(1, 1), Cells(1, 12)).Copy Cells(L + 1, 1).Select ActiveSheet.Paste Range("A1:L1").Select Application.CutCopyMode = False Selection.ClearContents Sheets("Sheet1").Select j = j + 3 Next j Sheets("Sheet3").Select Range("A1").Select End Sub

CyE7Dqwf.rar (7.15 KB, 下载次数: 17)

2005-8-5 11:23 上传

点击文件名下载附件
请守柔版主帮忙优化代码！

守柔

我简单地做了一下，请楼主运行一下，有问题，再交流： Option Explicit Sub Example() Dim MyRange As Range, I As Range, aRange As Range, EndRow As Long Application.ScreenUpdating = False With Sheets("Sheet1") '定义一个RANGE对象,从A2到A列最后一个数据单元格区域 Set MyRange = .Range("A2:" & .[A65536].End(xlUp).Address) '在指定RANGE对象中循环 For Each I In MyRange '定义一个Range对象 Set aRange = .Range(I, I.Offset(, 4)) With Sheets("Sheet3") If I.Row Mod 3 = 2 Then '取得目标工作表的最后一个数据单元格的下一个单元格(空白)行号 EndRow = .[A65536].End(xlUp).Offset(1, 0).Row '指定区域数值 .Range("A" & EndRow & ":" & "D" & EndRow).Value = aRange.Value ElseIf I.Row Mod 3 = 0 Then EndRow = .[E65536].End(xlUp).Offset(1, 0).Row .Range("E" & EndRow & ":" & "H" & EndRow).Value = aRange.Value Else EndRow = .[I65536].End(xlUp).Offset(1, 0).Row .Range("I" & EndRow & ":" & "L" & EndRow).Value = aRange.Value End If End With Next End With Application.ScreenUpdating = True End Sub '----------------------

[此贴子已经被作者于2005-8-5 12:09:20编辑过]

xiangdhai

谢谢，但不知自己写的代码错在哪里，还望指教。

守柔

请楼主帮我解释一下这些代码的意义：

L = WorksheetFunction.Count(Range("A1:A1000")) Range(Cells(1, 1), Cells(1, 12)).Copy Cells(L + 1, 1).Select ActiveSheet.Paste Range("A1:L1").Select Application.CutCopyMode = False Selection.ClearContents Sheets("Sheet1").Select

xiangdhai

计算表3中单元格A1:A1000中非空单元格的数量

L = WorksheetFunction.Count(Range("A1:A1000"))

选择并复制A1:A12区域 Range(Cells(1, 1), Cells(1, 12)).Copy 选择Cells(L + 1, 1).单元格，粘贴

Cells(L + 1, 1).Select ActiveSheet.Paste

清除A1:L1单元格内容 Range("A1:L1").Select Application.CutCopyMode = False Selection.ClearContents Sheets("Sheet1").Select