Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1773|回复: 8

[已解决]请老师编写代码

[复制链接]
发表于 2013-3-7 21:08 | 显示全部楼层 |阅读模式
请老师帮助编写下面二个代码
1、从表1中提取与表2数字不同的行,删除数字相同的行,然后生成表3。
2、从表1与表2中提取数字相同的行,删除数字不同的行,然后生成表4。
谢谢!
最佳答案
2013-3-7 21:37
  1. Sub 生成不同与相同表格()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 生成不同与相同表格
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/3/7
  6. ' Purpose   : 字典装数组,字典生成不同与相同表格
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim arr1, arr2, i As Long
  10.     Dim arrTemp
  11.     Dim Str$
  12.     Application.ScreenUpdating = False
  13.    
  14.     arr1 = Range("a1").CurrentRegion
  15.     arr2 = Range("j1").CurrentRegion

  16.     Dim dic As Object, dic3 As Object, dic4 As Object

  17.     Set dic = CreateObject("scripting.dictionary")
  18.     Set dic3 = CreateObject("scripting.dictionary")
  19.     Set dic4 = CreateObject("scripting.dictionary")

  20.     For i = LBound(arr2) + 1 To UBound(arr2)
  21.         arrTemp = WorksheetFunction.Index(arr2, i, 0)
  22.         dic(Join(arrTemp, "#")) = ""
  23.     Next

  24.     For i = LBound(arr1) + 1 To UBound(arr1)
  25.         arrTemp = WorksheetFunction.Index(arr1, i, 0)
  26.         Str = Join(arrTemp, "#")
  27.         If Not dic.exists(Str) Then
  28.             dic3(dic3.Count + 1) = arrTemp
  29.         Else
  30.             dic4(dic4.Count + 1) = arrTemp
  31.         End If
  32.     Next
  33.     Range("s1").CurrentRegion = ""
  34.     Range("ab1").CurrentRegion = ""
  35.     Range("s1") = "表3"
  36.     Range("ab1") = "表4"
  37.     If dic3.Count > 0 Then
  38.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic3.items))
  39.         Range("s2").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  40.     End If
  41.    
  42.     If dic4.Count > 0 Then
  43.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic4.items))
  44.         Range("ab2").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  45.     End If
  46.     Application.ScreenUpdating = True
  47.     MsgBox "完成"
  48. End Sub
复制代码

提取数字不同和相同的行.rar

8.38 KB, 下载次数: 3

发表于 2013-3-7 21:15 | 显示全部楼层
回复

使用道具 举报

发表于 2013-3-7 21:32 | 显示全部楼层
  1. Sub test3()
  2.     Dim arr1, arr2, i As Long
  3.     Dim arrTemp
  4.     Dim Str$

  5.     arr1 = Range("a1").CurrentRegion
  6.     arr2 = Range("j1").CurrentRegion

  7.     Dim dic As Object, dic3 As Object, dic4 As Object

  8.     Set dic = CreateObject("scripting.dictionary")
  9.     Set dic3 = CreateObject("scripting.dictionary")
  10.     Set dic4 = CreateObject("scripting.dictionary")

  11.     For i = LBound(arr2) + 1 To UBound(arr2)
  12.         arrTemp = WorksheetFunction.Index(arr2, i, 0)
  13.         dic(Join(arrTemp, "#")) = ""
  14.     Next

  15.     For i = LBound(arr1) + 1 To UBound(arr1)
  16.         arrTemp = WorksheetFunction.Index(arr1, i, 0)
  17.         Str = Join(arrTemp, "#")
  18.         If Not dic.exists(Str) Then
  19.             dic3(dic3.Count + 1) = arrTemp
  20.         Else
  21.             dic4(dic4.Count + 1) = arrTemp
  22.         End If
  23.     Next
  24.         
  25.     If dic3.Count > 0 Then
  26.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic3.items))
  27.         Range("s17").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  28.     End If
  29.    
  30.     If dic4.Count > 0 Then
  31.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic4.items))
  32.         Range("ab17").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  33.     End If
  34.     MsgBox "完成"
  35. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-3-7 21:32 | 显示全部楼层
hwc2ycy 发表于 2013-3-7 21:15
是要求对应的数字相同不?

是要求对应的数字相同,谢谢!!!!!!!!!!!!!!!
回复

使用道具 举报

发表于 2013-3-7 21:33 | 显示全部楼层
表3,表4分别输出到S17和AB17位置了。
回复

使用道具 举报

发表于 2013-3-7 21:34 | 显示全部楼层
  1. Sub lqxs()
  2. Dim Arr1, i&, Arr2, j&, r3%, Arr3(), r4%, Arr4()
  3. Dim d, d1, t, x$
  4. Set d = CreateObject("Scripting.Dictionary")
  5. Set d1 = CreateObject("Scripting.Dictionary")
  6. Sheet1.Activate
  7. Arr1 = [a1].CurrentRegion
  8. Arr2 = [j1].CurrentRegion
  9. For i = 2 To UBound(Arr1)
  10.     x = ""
  11.     For j = 1 To UBound(Arr1, 2)
  12.         x = x & Arr1(i, j) & ","
  13.     Next
  14.     d(x) = ""
  15. Next
  16. For i = 2 To UBound(Arr2)
  17.     x = ""
  18.     For j = 1 To UBound(Arr2, 2)
  19.         x = x & Arr2(i, j) & ","
  20.     Next
  21.     d1(x) = ""
  22.     If d.exists(x) Then
  23.         r4 = r4 + 1
  24.         ReDim Preserve Arr4(1 To r4)
  25.         Arr4(r4) = x
  26.     End If
  27. Next
  28. For i = 2 To UBound(Arr1)
  29.     x = ""
  30.     For j = 1 To UBound(Arr1, 2)
  31.         x = x & Arr1(i, j) & ","
  32.     Next
  33.     If Not d1.exists(x) Then
  34.         r3 = r3 + 1
  35.         ReDim Preserve Arr3(1 To r3)
  36.         Arr3(r3) = x
  37.     End If
  38. Next
  39. Application.DisplayAlerts = False
  40. [s2].Resize(UBound(Arr3), 1) = Application.Transpose(Arr3)
  41. [ab2].Resize(UBound(Arr4), 1) = Application.Transpose(Arr4)
  42. [s2].Resize(UBound(Arr3)).TextToColumns Comma:=True
  43. [ab2].Resize(UBound(Arr4)).TextToColumns Comma:=True
  44. Application.DisplayAlerts = True
  45. End Sub
复制代码

提取数字不同和相同的行0307.rar

10.85 KB, 下载次数: 3

回复

使用道具 举报

发表于 2013-3-7 21:37 | 显示全部楼层    本楼为最佳答案   
  1. Sub 生成不同与相同表格()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 生成不同与相同表格
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/3/7
  6. ' Purpose   : 字典装数组,字典生成不同与相同表格
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim arr1, arr2, i As Long
  10.     Dim arrTemp
  11.     Dim Str$
  12.     Application.ScreenUpdating = False
  13.    
  14.     arr1 = Range("a1").CurrentRegion
  15.     arr2 = Range("j1").CurrentRegion

  16.     Dim dic As Object, dic3 As Object, dic4 As Object

  17.     Set dic = CreateObject("scripting.dictionary")
  18.     Set dic3 = CreateObject("scripting.dictionary")
  19.     Set dic4 = CreateObject("scripting.dictionary")

  20.     For i = LBound(arr2) + 1 To UBound(arr2)
  21.         arrTemp = WorksheetFunction.Index(arr2, i, 0)
  22.         dic(Join(arrTemp, "#")) = ""
  23.     Next

  24.     For i = LBound(arr1) + 1 To UBound(arr1)
  25.         arrTemp = WorksheetFunction.Index(arr1, i, 0)
  26.         Str = Join(arrTemp, "#")
  27.         If Not dic.exists(Str) Then
  28.             dic3(dic3.Count + 1) = arrTemp
  29.         Else
  30.             dic4(dic4.Count + 1) = arrTemp
  31.         End If
  32.     Next
  33.     Range("s1").CurrentRegion = ""
  34.     Range("ab1").CurrentRegion = ""
  35.     Range("s1") = "表3"
  36.     Range("ab1") = "表4"
  37.     If dic3.Count > 0 Then
  38.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic3.items))
  39.         Range("s2").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  40.     End If
  41.    
  42.     If dic4.Count > 0 Then
  43.         arrTemp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic4.items))
  44.         Range("ab2").Resize(UBound(arrTemp), UBound(arrTemp, 2)) = arrTemp
  45.     End If
  46.     Application.ScreenUpdating = True
  47.     MsgBox "完成"
  48. End Sub
复制代码
回复

使用道具 举报

发表于 2013-3-7 21:39 | 显示全部楼层
提取数字不同和相同的行.rar (13.24 KB, 下载次数: 5)
回复

使用道具 举报

 楼主| 发表于 2013-3-13 21:19 | 显示全部楼层
hwc2ycy 发表于 2013-3-7 21:39

老师您好:请您把该题提取数字相同和不同行的代码分别编写。谢谢!

提取数字不同和相同的行.rar

12.06 KB, 下载次数: 0

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 21:43 , Processed in 0.985590 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表