[已解决]如何找出两个单元格中的相同字符

hhaa999

haSH8Alm.rar (7.53 KB, 下载次数: 70)

2010-6-10 12:24 上传

点击文件名下载附件
如何找出两个单元格中的相同字符

最佳答案

月排行榜 / 总排行榜

amulee

2010-6-10 15:58

Sub test()
Dim arrYS, arrJG
arrYS = Range("A1:C" & Range("A65536").End(xlUp).Row)
For i = 2 To UBound(arrYS)
  arrYS(i, 3) = ""
  For j = 0 To 9
    If InStr(1, arrYS(i, 1), j) > 0 And InStr(1, arrYS(i, 2), j) > 0 Then
        arrYS(i, 3) = arrYS(i, 3) & j
    End If
  Next j
Next
[A1].Resize(i - 1, 3) = arrYS
End Sub

跳转到最佳答案楼层

上清宫主

试试：

Sub test()
Dim ar()
i% = [a65536].End(xlUp).Row
Range("C2:C" & i).ClearContents
ar = Range("a2:c" & i).Value
For i = 1 To UBound(ar)
  Do While Len(ar(i, 1)) * Len(ar(i, 2))
     s$ = Left(ar(i, 1), 1)
     If InStr(ar(i, 2), s) Then
        If Len(ar(i, 3)) Then
          ar(i, 3) = ar(i, 3) & s
        Else
           ar(i, 3) = "'" & s
        End If
        ar(i, 2) = Replace(ar(i, 2), s, "")
     End If
     ar(i, 1) = Replace(ar(i, 1), s, "")
  Loop
Next
[c2].Resize(i - 1) = Application.Index(ar, , 3)
End Sub

fjmxwrs

上一课V预班刚好学习循环语句,正好当成练习,终于完成了,这应该是你想要的结果.

Sub 相同字符()
  Dim a As Integer
  Dim b As Integer
  Dim d As Integer
  Sheets("sheet1").Range("C2:C65536").ClearContents
    With Sheets("sheet1")
          For d = 2 To .Range("A65536").End(xlUp).Row
              For a = 1 To Len(.Cells(d, 1))
                For b = 1 To Len(.Cells(d, 2))
                  If Mid(.Cells(d, 1), a, 1) = Mid(.Cells(d, 2), b, 1) And Mid(.Cells(d, 1), a, 1) <> .Cells(d, 3) Then
                     If .Cells(d, 3) = "" Then
                        .Cells(d, 3) = Mid(.Cells(d, 1), a, 1)
                     Else
                        .Cells(d, 3) = .Cells(d, 3) & Mid(.Cells(d, 1), a, 1)
                     End If
                  End If
                Next b
             Next a
          Next d
    End With
End Sub

prDGxu6c.rar (8 KB, 下载次数: 40)

2010-6-10 14:38 上传

点击文件名下载附件
如何找出两个单元格中的相同字符

fjmxwrs

二楼的更完美,三楼的如果数据中有重复的,结果会重复

蒸蒸日上

[em04]看得我要花缭乱的！好佩服呦！[em23][em23]

diao0109

这个太深奥了，，搞不明白。

amulee

Sub test()
Dim arrYS, arrJG
arrYS = Range("A1:C" & Range("A65536").End(xlUp).Row)
For i = 2 To UBound(arrYS)
  arrYS(i, 3) = ""
  For j = 0 To 9
    If InStr(1, arrYS(i, 1), j) > 0 And InStr(1, arrYS(i, 2), j) > 0 Then
        arrYS(i, 3) = arrYS(i, 3) & j
    End If
  Next j
Next
[A1].Resize(i - 1, 3) = arrYS
End Sub

fjmxwrs

终于把三楼会重复的问题解决了.只需要加上有色的代码就行了.

Sub 相同字符()
  Dim a As Integer
  Dim b As Integer
  Dim d As Integer
  Sheets("sheet1").Range("C2:C65536").ClearContents
    With Sheets("sheet1")
          For d = 2 To .Range("A65536").End(xlUp).Row
              For a = 1 To Len(.Cells(d, 1))
                For b = 1 To Len(.Cells(d, 2))
                   If Instr(.Cells(d,3),Mid(.Cells(d,1),a,1)=0 Then

                      If Mid(.Cells(d, 1), a, 1) = Mid(.Cells(d, 2), b, 1) Then
                         If .Cells(d, 3) = "" Then
                            .Cells(d, 3) = Mid(.Cells(d, 1), a, 1)
                         Else
                            .Cells(d, 3) = .Cells(d, 3) & Mid(.Cells(d, 1), a, 1)
                         End If
                      End If

                   End If
                Next b
             Next a
          Next d
    End With
End Sub

hhaa999

If Instr(.Cells(d,3),Mid(.Cells(d,1),a,1)=0 Then 楼上语法错误

修改 If Instr(.Cells(d,3),Mid(.Cells(d,1),a,1)）=0 Then

[此贴子已经被作者于2010-6-11 6:27:48编辑过]