[已解决]请教高手怎么修改代码将数值去空去重复制

东方智彩

请教高手怎么修改代码将A11以下的数值去空去重复制到表2，谢谢！

VvUX06UZ.rar (13.19 KB, 下载次数: 17)

2010-3-8 15:14 上传

点击文件名下载附件
请教高手怎么修改代码将数值去空去重复制

最佳答案

月排行榜 / 总排行榜

老申

2010-3-9 00:10

QUOTE:

以下是引用开辆小富康在2010-3-8 17:05:00的发言：
Sub 去空去重复()
 Dim Dic As Object, Arr, rg As Range
 Set Dic = CreateObject("scripting.dictionary")
 With Sheets("1")
  Arr = .Range("A11", .Range("a65536").End(xlUp))
 End With
 For i = 1 To UBound(Arr)
  If Arr(i, 1) <> "" Then Dic(Arr(i, 1)) = ""
 Next i
 Set rg = Sheets("2").Range("iv6").End(xlToLeft).Offset(0, 1).Resize(Dic.Count, 1)
 rg.NumberFormatLocal = "@"
 rg = Application.Transpose(Dic.keys)
 Set rg = Nothing
 Set Dic = Nothing
End Sub

试试这代码

[此贴子已经被作者于2010-3-9 0:14:42编辑过]

跳转到最佳答案楼层

东方智彩

请教高手怎么修改代码将数值去空去重复制

djyjysxxs

慢点的：

Sub crdd()
l = 11
With Sheets("1")
For k = 11 To .[a65536].End(xlUp).Row
  If Len(.Cells(k, 1).Text) > 0 Then
    If WorksheetFunction.CountIf(.Range("a10:a" & l - 1), "=" & .Cells(k, 1).Text) < 1 Then
      .Cells(l, 1) = .Cells(k, 1).Text
      l = l + 1
    End If
  End If
Next
.Range("a" & l & ":a" & k).Clear
End With
End Sub

东方智彩

老师去空去重后是复制到表2中不是在复制在原来的位置，请老师再修改一下，谢谢！

开辆小富康

Sub 去空去重复()
 Dim Dic As Object, Arr
 Set Dic = CreateObject("scripting.dictionary")
 With Sheets("1")
  Arr = .Range("A11", .Range("a65536").End(xlUp))
 End With
 For i = 1 To UBound(Arr)
  If Arr(i, 1) <> "" Then Dic(Arr(i, 1)) = ""
 Next i
 Sheets("2").Columns(1).NumberFormatLocal = "@"
 Sheets("2").Range("A1").Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
End Sub

开辆小富康

复制在哪儿啊？请3楼改吧。下班回家

东方智彩

各位老师你们的代码我都看过了,去空去重并复制到表2的问题是解决了,但少了原代码还能重复执行宏时可向右自动累加排列,如第一次复制到表2的A列后如再执行宏还能将复制的数据自动排到B列、C列、D列等依次类推.......所以还请老师再修改一下，谢谢啦！

再附上原代码：

Sub crdd()
k = 1
If Cells(11, k) = "" Then Exit Sub
pcol = WorksheetFunction.CountA(Sheets("2").Range("d6:cy6")) + 4
Arr = Sheets("1").Cells(11, k).Resize(1000, 1)
Sheets("2").Cells(6, pcol).Resize(1000, 1) = Arr
End Sub

老申

QUOTE:

以下是引用开辆小富康在2010-3-8 17:05:00的发言：
Sub 去空去重复()
 Dim Dic As Object, Arr, rg As Range
 Set Dic = CreateObject("scripting.dictionary")
 With Sheets("1")
  Arr = .Range("A11", .Range("a65536").End(xlUp))
 End With
 For i = 1 To UBound(Arr)
  If Arr(i, 1) <> "" Then Dic(Arr(i, 1)) = ""
 Next i
 Set rg = Sheets("2").Range("iv6").End(xlToLeft).Offset(0, 1).Resize(Dic.Count, 1)
 rg.NumberFormatLocal = "@"
 rg = Application.Transpose(Dic.keys)
 Set rg = Nothing
 Set Dic = Nothing
End Sub

试试这代码

[此贴子已经被作者于2010-3-9 0:14:42编辑过]

东方智彩

谢谢老申老师啦，正是要这个效果，[em17][em23]