【v1-6综合练习题2】卡片转数据表格式存放

至尊宝_98_76 · 发表于 2007-12-17 10:52

这个又快了很多，最快0.007秒，最慢0.017秒，数据太少，不稳定了。Sub xx() Dim x As Integer, y As Integer, z As Integer, t Application.ScreenUpdating = False x = Sheet1.Range("a65536").End(xlUp).Row z = 2 t = Timer For y = 1 To x Step 5    Range("a" & z & ":d" & z) = Application.Transpose(Sheet1.Range("b" & y & ":b" & y + 4))    z = z + 1 Next MsgBox Timer - t Application.ScreenUpdating = True End Sub

zgwei050 · 发表于 2007-12-17 17:43

自己先独立完成(修改）：Sub 卡片1() Dim MRG As Range Dim AAA As String Dim BBB As Long Dim P As Long Dim Q As Long    Sheets("数据表").Range("A2:A65536").ClearContents   With Sheets("卡片")     Q = .Range("A65536").End(xlUp).Row     Set MRG = .Range("A1:A" & Q).Find("姓名")       AAA = MRG.Address     Do       BBB = MRG.Row       P = Sheets("数据表").Range("A65536").End(xlUp).Row       For i = BBB To BBB + 3       Sheets("数据表").Cells(P + 1, i - BBB + 1) = .Cells(i, 2)       Next i       Set MRG = .Range("A1:A65536").FindNext(MRG)     Loop Until MRG.Address = AAA   End With End Sub 再看其他网友的程序，哇，这么多！慢慢看！

[此贴子已经被作者于2007-12-17 19:30:56编辑过]

小鲫鱼 · 发表于 2007-12-17 18:22

要是上表的表格有几列怎么办.

春雨 · 发表于 2007-12-17 19:00

先下载

zgwei050 · 发表于 2007-12-17 19:11

22楼我的程序中，总是跳过“卡片”工作表中第1行要查找的内容，从第2行开始查找，最后查找行反而是第1行内容，奇怪！解决办法：“卡片”工作表的最前面插入1空行，运行一下到可以了！难道do...... Loop Until.....语句开始不查第1行的A1？

[此贴子已经被作者于2007-12-17 19:25:30编辑过]

cfq-xxj · 发表于 2007-12-18 20:51

Sub Macro1() Dim i, j, k As Integer For i = 1 To 100 Step 5  j = Range("c65536").End(xlUp).Row + 1     Range("a" & i).CurrentRegion.Activate     Selection.Copy      Range("c" & j).Select     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _         False, Transpose:=True     Next i  For k = Range("c65536").End(xlUp).Row To 3 Step -1  If Range("c" & k).Value = "姓名" Then  Range("C" & k & ":F" & k).Delete shift:=xlUp  End If  Next k  Range("c1:f1").Delete shift:=xlUp End Sub 这个可能是最慢的了

mjm96511 · 发表于 2007-12-18 22:37

[此贴子已经被作者于2007-12-18 22:46:46编辑过]

cfq-xxj · 发表于 2007-12-18 22:40

Sub 名片() Dim i, j, H As Integer For i = 1 To 100 Step 5 H = Sheets(2).Range("a65536").End(xlUp).Row + 1 varArray = Sheets(1).Range("a" & i).CurrentRegion Sheets(2).Range("A" & H & ":d" & H + 1) = Application.WorksheetFunction.Transpose(varArray) Next i 删除 End Sub Sub 删除() Dim ran As Range For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row + 1 If Range("a" & i) = "姓名" Then If ran Is Nothing Then Set ran = Rows(i) Else Set ran = Union(ran, Rows(i)) End If End If Next i 'ran.Select ran.Delete shift:=xlUp End Sub

cfq-xxj · 发表于 2007-12-18 22:43

<div class="msgheader">QUOTE:</div><div class="msgborder">以下是引用mjm96511在2007-12-18 22:37:00的发言： Sub 数据转换() Dim a As Integer, b As Integer a = Sheets("卡片").Range("A65536").End(xlUp).Row For i = 1 To Int(a / 5)     For j = 1 To 4         b = 5 * (i - 1) + j         Sheets("数据表").Cells(i, j) = Sheets("卡片").Cells(b, 2)     Next Next End Sub</div>高手

mjm96511 · 发表于 2007-12-18 22:44

Sub 转换() Dim a As Integer, b As Integer a = Sheets("卡片").Range("A65536").End(xlUp).Row For i = 1 To Int(a / 5)     For j = 1 To 4         b = 5 * (i - 1) + j         Sheets("数据表").Cells(i, j) = Sheets("卡片").Cells(b, 2)     Next Next End Sub

		自动登录	找回密码
密码			注册

[习题] 【v1-6综合练习题2】卡片转数据表格式存放

好厉害的