求助VBA代码

秦蜀新 · 发表于 2018-8-10 20:51

请各位老师帮忙写VBA代码：见附件：在B3:J18区域内有一些数字，想达到的目的是：1、在此区域其它空单元格内输入原来有的数字，回车后能清除原来的相同数字（例如：B3单元格原来的数字是12，在C4单元格输入12，回车后能清除B3单元格中的12，留下C4单元格的12），2、清除原来的数字后，能在清除的单元格中继续输入数字（例如：在B3单元格被清除后，能继续在B3单元格内输入数字，如果输入其它单元格内有的数字，则把其它单元格有相同的数字清除，保留现在的数字）。非常感谢！

xiaoxia520 · 发表于 2018-8-10 21:37

Dim rng As Range, a As Range, frng As Range
Set rng = Range(Cells(3, 2), Cells(18, 10))
With rng
Set a = .Find(Target.Value, , , xlWhole)
If Not a Is Nothing Then
Set frng = a
End If
Do
Set a = .FindNext(frng)
If frng.Address <> a.Address Then
If frng.Address = Target.Address Then
a.Value = ""
Exit Do
Else
frng.Value = ""
Exit Do
End If
End If
Loop
End With

复制代码

新手上路

秦蜀新 · 发表于 2018-8-11 20:22

老师好！我把代码复制进去后出现运行错误，麻烦帮忙看一下，谢谢！复制的代码如下：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, a As Range, frng As Range
Set rng = Range(Cells(3, 2), Cells(18, 10))
With rng
      Set a = .Find(Target.Value, , , xlWhole)
      If Not a Is Nothing Then
         Set frng = a
      End If
      Do
         Set a = .FindNext(frng)
         If frng.Address <> a.Address Then
            If frng.Address = Target.Address Then
                  a.Value = ""
                  Exit Do
                  Else
                     frng.Value = ""
                     Exit Do
            End If
         End If
      Loop
End With
End Sub

humanmagic · 发表于 2018-8-12 08:08

本帖最后由 humanmagic 于 2018-8-12 08:45 编辑

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngs As Range
Set rngs = Range("B3:J18")
Dim findRng As Range
Dim findAddress As String
If Intersect(Target, rngs) Is Nothing Then
Exit Sub
End If
Set findRng = rngs.Find(Target.Value, , , xlWhole)
findAddress = findRng.Address
If findAddress = Target.Address Then
Set findRng = rngs.FindNext(findRng)
findAddress = findRng.Address
If findAddress = Target.Address Then
Exit Sub
End If
End If
Do
If findRng Is Nothing Then
Exit Sub
End If
Debug.Print findRng.Address
If Target.Address = findRng.Address Then
findAddress = findRng.Address
Set findRng = rngs.FindNext(findRng)
End If
Application.EnableEvents = False
findRng.Value = ""
Application.EnableEvents = True
Set findRng = rngs.FindNext(findRng)
Loop While findRng.Address <> findAddress
End Sub

复制代码

秦蜀新 · 发表于 2018-8-12 20:39

老师好！我把代码复制了，还是不行，出现：运行时错误“91”、对象变量或With块变量未设置的对话框，我启用了宏。我把附件发给你，请帮忙看看。非常感谢！

秦蜀新 · 发表于 2018-8-12 20:51

保存代码时出现这样的对话框。

humanmagic · 发表于 2018-8-13 23:30

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngs As Range
Set rngs = Range("B3:J18")
Dim findRng As Range
Dim findAddress As String
If Intersect(Target, rngs) Is Nothing Then
Exit Sub
End If
Set findRng = rngs.Find(Target.Value, , , xlWhole)
findAddress = findRng.Address
If findAddress = Target.Address Then
Set findRng = rngs.FindNext(findRng)
findAddress = findRng.Address
If findAddress = Target.Address Then
Exit Sub
End If
End If
Do
If Target.Address = findRng.Address Then
findAddress = findRng.Address
Set findRng = rngs.FindNext(findRng)
End If
Application.EnableEvents = False
findRng.Value = ""
Application.EnableEvents = True
Set findRng = rngs.FindNext(findRng)
Loop While Not findRng Is Nothing And findRng.Address <> findAddress
End Sub

复制代码

秦蜀新 · 发表于 2018-8-14 10:02

老师好！我把代码复制进去后，保存时出现启用宏的对话框，启用宏后出“现隐私问题”警告框，在单元格中输入相同数字后，全部清除，附近发不过去，麻烦在百忙中看一下上次发的代码，非常感谢！

秦蜀新 · 发表于 2018-8-14 11:02

能否和你加入QQ好友聊？

humanmagic · 发表于 2018-8-14 20:26

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngs As Range
Set rngs = Range("B3:J18")
Dim arr
arr = rngs.Value
Dim x As Byte, y As Byte, str As String
x = Target.Row - rngs.Row + 1
y = Target.Column - rngs.Column + 1
str = Target.Text
Dim i As Byte, j As Byte
For i = LBound(arr) To UBound(arr)
For j = LBound(arr, 2) To UBound(arr, 2)
If i <> x And j <> y Then
If arr(i, j) = str Then
arr(i, j) = ""
End If
End If
Next j
Next i
Application.EnableEvents = False
rngs.Value = arr
Application.EnableEvents = True
End Sub

复制代码

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

[求助] 求助VBA代码