求助复制难题

makou

请论坛高手出手相助,在此表示感谢!

问题见附件

情比金坚

  一体化的方式想不到，

不过可以用countif()很容易的找出彼此不重复的数据，和重复两次以上的数据。

再用复制----选择性粘贴可以完成你的要求。

[此贴子已经被作者于2004-12-12 15:32:05编辑过]

foxxp

Sub test()

  Dim sh1 As Worksheet

  Dim sh2 As Worksheet

  Dim sht As Worksheet

  '计数器i表示sheet1的当前行

  Dim i As Integer

  '计数器j表示sheet3的当前行

  Dim j As Integer

  Dim f As Integer

  '从第二行开始，忽略标题

  i = 2

  Set sh1 = Worksheets("sheet1")

  Set sh2 = Worksheets("sheet2")

  Set sht = Worksheets("sheet3")

  '清空sheet3的内容

  sht.Cells.ClearContents

  '填写标题

  sht.Cells(1, 1) = sh1.Cells(1, 1)

  sht.Cells(1, 2) = sh1.Cells(1, 2)

  j = 2

  Do While True

     '遇到空行结束

     If sh1.Cells(i, 1) = "" Then

        Exit Do

     End If

     On Error Resume Next

     '假设找不到

     f = -1

     f = Application.WorksheetFunction.Match(sh1.Cells(i, 1), sh2.Range("a:a"), 0)

     '如果找不到,f不会被赋值,保持-1

     If f = -1 Then

        sht.Cells(j, 1) = sh1.Cells(i, 1)

        sht.Cells(j, 2) = sh1.Cells(i, 2)

        j = j + 1

     End If

     'If Application.WorksheetFunction.Match(sh1.Cells(i, 1), sh2.Range("a:a"), 0) > 0 Then

     'End If

     i = i + 1

  Loop

End Sub

情比金坚

那个重复了两次地“C”没有被找到呢

makou

谢谢版主和Foxxp，对我的帮助很大，如果有解决重复数据的方案一定告诉我一下，再次感谢！

老鬼

Sub copyit()

Dim s1 As Worksheet

Dim s2 As Worksheet

Dim s3 As Worksheet

Dim x

Dim y

Dim i

    Set s1 = Worksheets("sheet1")

    Set s2 = Worksheets("sheet2")

    Set s3 = Worksheets("sheet3")

    x = s1.[a2].End(xlDown).Row

    y = s2.[a2].End(xlDown).Row

For Each CEL2 In s1.Range("A2:A" & x) '求表1不在表2中的值

    i = 0

        For Each CEL In s2.Range("A2:A" & y)

        If CEL2 = CEL Then

        i = i + 1

        End If

        Next

    If i <> 1 Then

    s3.[A65536].End(xlUp).Offset(1, 0).Value = CEL2.Value

    s3.[A65536].End(xlUp).Offset(0, 1).Value = CEL2.Offset(0, 1).Value

    End If

Next

For Each CEL2 In s2.Range("A2:A" & y) '求表1在表2中，但有重复的值

    i = 0

        For Each CEL In s1.Range("A2:A" & x)

        If CEL2 = CEL Then

        i = i + 1

        End If

        Next

    If i <> 1 Then

    s3.[A65536].End(xlUp).Offset(1, 0).Value = CEL2.Value

    s3.[A65536].End(xlUp).Offset(0, 1).Value = CEL2.Offset(0, 1).Value

    End If

Next

End Sub