非常感谢lzyamo3057老师帮处理下C列数据在B列数据的位置问题，谢谢！

abcttud · 发表于 2013-4-24 14:16

xuexi2xuexi 发表于 2013-4-24 14:05
换一种思路，用ACTIVE按钮就可以了。（自己可以再加调整)
Sub test()
Dim Arr, D, i&

谢谢老师的帮助，但原来的功能不能实现了吗？

另我工作电脑上比较完美，按钮是实时滑动的（不须单击才出现）。但老师的水平还是很佩服的。
另一题老师帮看看（网址已发）

xuexi2xuexi · 发表于 2013-4-24 14:21

abcttud 发表于 2013-4-24 14:16
谢谢老师的帮助，但原来的功能不能实现了吗？

另我工作电脑上比较完美，按钮是实时滑动的（不须单击才 ...

忘记链接了，再试一下。

abcttud · 发表于 2013-4-24 15:17

xuexi2xuexi 发表于 2013-4-24 14:21
忘记链接了，再试一下。

老师辛苦了，可以了，另外按钮实时滑动帮试试能否实现。

vtejeyp1 · 发表于 2013-4-25 15:53

挺复杂的，没接触过这些东西

abcttud · 发表于 2013-5-13 13:01

lzyamo3057 发表于 2013-4-24 12:43

请老师帮处理下

麻烦lzyamo3057老师帮处理下如数据不颜色，谢谢！.rar (8.06 KB, 下载次数: 3)

lzyamo3057 · 发表于 2013-5-13 13:30

Sub test()
Dim arr, d, i, brr(), rng As Range, rrng As Range
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 2)) = arr(i, 1)
Next
For i = 1 To UBound(arr)
k = k + 1
ReDim Preserve brr(1 To k)
If Not d.exists(Val(Right(Val(Cells(i, 3)), 6))) Then
brr(k) = ""
If rng Is Nothing Then
Set rng = Cells(i, 3)
Else
Set rng = Union(rng, Cells(i, 3))
End If
Else
brr(k) = d(Val(Right(Val(Cells(i, 3)), 6)))
d.Remove (Val(Right(Val(Cells(i, 3)), 6)))
End If
Next
k = d.keys
For i = LBound(k) To UBound(k)
For j = LBound(arr) To UBound(arr)
If k(i) = Cells(j, 2) Then
If rrng Is Nothing Then
Set rrng = Cells(j, 2)
Else
Set rrng = Union(rrng, Cells(j, 2))
End If
End If
Next
Next
rrng.Font.ColorIndex = 3
rng.Font.ColorIndex = 3
Range("d1").Resize(UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
Set d = Nothing
End Sub

复制代码

lzyamo3057 · 发表于 2013-5-13 13:31

请测试。。。。

lzyamo3057 · 发表于 2013-5-14 13:31

abcttud 发表于 2013-5-13 13:01
请老师帮处理下

Sub test()
Dim arr, d, i, brr(), rng As Range, rrng As Range
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
      d(arr(i, 2)) = arr(i, 1)
Next
For i = 1 To UBound(arr)
      k = k + 1
      ReDim Preserve brr(1 To k)
      If Not d.exists(Val(Right(Val(Cells(i, 3)), 6))) Then
         brr(k) = ""
         If rng Is Nothing Then
            Set rng = Cells(i, 3)
         Else
            Set rng = Union(rng, Cells(i, 3))
         End If
      Else
         brr(k) = d(Val(Right(Val(Cells(i, 3)), 6)))
         d.Remove (Val(Right(Val(Cells(i, 3)), 6)))
      End If
Next
k = d.keys
For i = LBound(k) To UBound(k)
      For j = LBound(arr) To UBound(arr)
         If k(i) = Cells(j, 2) Then
            If rrng Is Nothing Then
                  Set rrng = Cells(j, 2)
            Else
                  Set rrng = Union(rrng, Cells(j, 2))
            End If
         End If
      Next
Next
If Not rrng Is Nothing Then
      rrng.Font.ColorIndex = 3
End If
If Not rng Is Nothing Then
      rng.Font.ColorIndex = 3
End If
Range("d1").Resize(UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
Set d = Nothing
End Sub

abcttud · 发表于 2013-6-16 12:31

lzyamo3057 发表于 2013-4-24 12:23

麻烦lzyamo3057老师又遇新的实际问题

麻烦lzyamo3057老师又遇新的实际问题.rar (5.18 KB, 下载次数: 4)

abcttud · 发表于 2013-6-18 21:21

lzyamo3057 发表于 2013-5-14 13:31
Sub test()
Dim arr, d, i, brr(), rng As Range, rrng As Range
Set d = CreateObject("scrip ...

麻烦lzyamo3057老师又遇新的实际问题.rar (5.14 KB, 下载次数: 8)

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

[已解决] 非常感谢lzyamo3057老师帮处理下C列数据在B列数据的位置问题，谢谢！

评分

评分