[已解决]工作表中的数据按奇数行复制提取到其他工作表

hhaa999

oEHg8DbC.rar (6.13 KB, 下载次数: 18)

2010-8-16 10:15 上传

点击文件名下载附件
工作表中的数据按奇数行复制提取到其他工作表

最佳答案

月排行榜 / 总排行榜

开辆小富康

2010-8-16 11:06

Sub CopyCont()
 Dim Arr
 Dim i&, j%
 Arr = Sheet1.UsedRange.Value
 If UBound(Arr) > 0 Then
  ReDim arrtemp(1 To Int(UBound(Arr) / 2) + 1, 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr) Step 2
     For j = 1 To UBound(Arr, 2)
      arrtemp((i + 1) / 2, j) = Arr(i, j)
     Next j
    Next i
 End If
 Sheet2.ClearArrows
 Sheet2.Range("a1").Resize(UBound(arrtemp), UBound(arrtemp, 2)) = arrtemp
 Sheet3.ClearArrows
 Sheet3.Range("a1").Resize(UBound(arrtemp), UBound(arrtemp, 2)) = arrtemp
 
End Sub

跳转到最佳答案楼层

sp356468826

数据量大，数组慢吧，V白路过，帮顶一下

chensir

我刷箱子

开辆小富康

Sub test() '(粘贴工作表)
Dim Rng As Range
Sheet2.Cells.Clear
Sheet1.UsedRange.Copy Sheet2.Range("a1")

With Sheet2
 Set Rng = .Range("a65536")
 For i = 2 To .UsedRange.Rows.Count Step 2
  Set Rng = Union(Rng, .Range("A" & i))
 Next
 Rng.EntireRow.Delete
End With
End Sub

飞天小猪

数据量大，数组慢吧，V白路过，帮顶一下

hhaa999

把sheet1的数据复制到sheet2后删除偶数行，能不能一步到位

[此贴子已经被作者于2010-8-16 10:53:21编辑过]

开辆小富康

Sub CopyCont()
 Dim Arr
 Dim i&, j%
 Arr = Sheet1.UsedRange.Value
 If UBound(Arr) > 0 Then
  ReDim arrtemp(1 To Int(UBound(Arr) / 2) + 1, 1 To UBound(Arr, 2))
    For i = 1 To UBound(Arr) Step 2
     For j = 1 To UBound(Arr, 2)
      arrtemp((i + 1) / 2, j) = Arr(i, j)
     Next j
    Next i
 End If
 Sheet2.ClearArrows
 Sheet2.Range("a1").Resize(UBound(arrtemp), UBound(arrtemp, 2)) = arrtemp
 Sheet3.ClearArrows
 Sheet3.Range("a1").Resize(UBound(arrtemp), UBound(arrtemp, 2)) = arrtemp
 
End Sub

htcaiwuke

8lCOoSRq.rar (8.85 KB, 下载次数: 19)

2010-8-16 11:09 上传

点击文件名下载附件
工作表中的数据按奇数行复制提取到其他工作表

开辆小富康

对。楼上的很好，用高级筛选就OK了。没A列也可以做

zh793026895

前来学习了，谢谢分享