修改一下代码

tanglf188

木虫 发表于 2023-1-6 16:17
你好  是这个意思  写做的很好。
用过后，发现好几个地方，我都没说明白 ，就是1： 输出列改在了D列。   ...

Sub DFG()
    Sheet1.Columns("D:D").ClearContents '清除D列数据，如果不想清除可以删除本行或标注掉。
    Sheet1.Range("D1") = "结果" '单元格D1初始赋值
    For i = 2 To Sheet1.Range("A" & Rows.Count).End(xlUp).Row '从A列第二行到最后一行执行循环
        st = Sheet1.Cells(i, 1) '取第i行，第一列数据
        Set findcell = Sheet2.Range("B:B").Find(st, LookAt:=xlPart)  '在表二里查找
        If Not findcell Is Nothing Then  '找到
            If Len(Sheet1.Cells(i, 4)) = 0 Then '判断待写入的单元格长度，是0则为空，写入数据
                With Sheet1.Cells(i, 4) '在第i行，第4列（D列）写入数据
                    .Value = "强"
                    .Font.Color = vbRed '字体颜色
                    .HorizontalAlignment = xlCenter '水平居中
                    .VerticalAlignment = xlCenter '垂直居中
                End With
            End If
        End If
    Next
    sh1 = InputBox("输入待修改的表名。" & Chr(10) & "点击取消放弃修改", "提示信息", Sheet1.Name)  '打开表一改名对话框,如果不用可以删除本行或标注掉
    If Len(sh1) > 1 Then Sheet1.Name = sh1 '修改表一的表名
    sh2 = InputBox("输入待修改的表名。" & Chr(10) & "点击取消放弃修改", "提示信息", Sheet2.Name) '打开表二改名对话框,如果不用可以删除本行或标注掉
    If Len(sh1) > 1 Then Sheet2.Name = sh2 '修改表二的表名
End Sub

tanglf188

附件里添加了表一第一列修改后自动执行的代码，注意当同一行的D列有数据则不修改了。

木虫

tanglf188 发表于 2023-1-6 17:03
附件里添加了表一第一列修改后自动执行的代码，注意当同一行的D列有数据则不修改了。

谢谢  也修改好了
好像还是D列都在执行  是否可以只让新录入的行执行呀？老的数据就不要执行了。

tanglf188

木虫 发表于 2023-1-6 17:54
谢谢  也修改好了
好像还是D列都在执行  是否可以只让新录入的行执行呀？老的数据就不要执行了。

附件里就是新修改的行执行，你双击Sheet1表就看到代码了，按钮是执行所有的行和改工作表名称的

psxk3535

木虫 发表于 2023-1-6 16:13
你好  是这个意思  写做的很好。
用过后，发现好几个地方，我都没说明白 ，就是1： 输出列改在了D列。   ...

重新改了一下

木虫

psxk3535 发表于 2023-1-7 01:02
重新改了一下

刚刚运行了2次 感觉这个很棒。有一个很小很小很小的问题需要纠正一下
就是整列字体都变红色了 这个不好
只让”强”变成红色就好

gwjkkkkk

木虫 发表于 2023-1-7 16:41
刚刚运行了2次 感觉这个很棒。有一个很小很小很小的问题需要纠正一下
就是整列字体都变红色了 这个不 ...

Sub TEST()
    Dim ar, i&, dic As Object, rng As Range
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Sheets(2).[B1].CurrentRegion
    For i = 2 To UBound(ar): dic(ar(i, 1)) = "": Next i
   
    With [A1].CurrentRegion
       ar = Intersect(.Offset(), .Offset(1))
    End With
    Set rng = [C2].Resize(UBound(ar))
    With rng
       .Font.ColorIndex = 0
       For i = 1 To UBound(ar)
         If dic.exists(ar(i, 1)) Then
           ar(i, 1) = "强"
           .Cells(i).Font.Color = vbRed
         Else
           ar(i, 1) = ""
         End If
        Next i
        .Value = ar
    End With
   
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

木虫 发表于 2023-1-7 16:41
刚刚运行了2次 感觉这个很棒。有一个很小很小很小的问题需要纠正一下
就是整列字体都变红色了 这个不 ...

请楼主参考附件。。。

psxk3535

木虫 发表于 2023-1-7 16:41
刚刚运行了2次 感觉这个很棒。有一个很小很小很小的问题需要纠正一下
就是整列字体都变红色了 这个不 ...

加了一个判断，这样就只有含“强”字的才会变红，就是代码越来越啰嗦

木虫

psxk3535 发表于 2023-1-7 22:06
加了一个判断，这样就只有含“强”字的才会变红，就是代码越来越啰嗦

你好   增加数据时   包含“”强“字的  字体不会变红了   尝试修改也改变