设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 遍历不重复字段标题
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2716|回复: 6

[已解决]遍历不重复字段标题

[复制链接]
发表于 2014-6-10 14:10 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 张雄友 于 2014-6-11 19:06 编辑

提取不重复字段标题。
最佳答案
月排行榜 / 总排行榜
grf1973
2014-6-11 09:53
你自己的代码可参照修改。
  1. Sub 用选择文件夹的方式提取不重复字段标题()
  2.     Dim sh As Worksheet, arr, d As Object, i&, j&, MyPath$
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.             .InitialFileName = ThisWorkbook.Path & ""
  5.             If .Show = False Then Exit Sub
  6.             MyPath = .SelectedItems(1) & ""
  7.     End With
  8.    
  9.     Set d = CreateObject("Scripting.Dictionary")
  10.     myname = Dir(MyPath & "*.xls*") '获取xls*文件
  11.     Do While myname <> ""
  12.         If myname <> ThisWorkbook.Name Then '不包括本工作簿
  13.             With GetObject(MyPath & myname)
  14.                 For Each sh In .Worksheets '遍历工作表
  15.                 c = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
  16.                     For j = 1 To c
  17.                         a = sh.Cells(1, j).Value
  18.                         If Len(a) > 0 Then d(a) = ""
  19.                     Next
  20.                 Next
  21.                 .Close False
  22.             End With
  23.         End If
  24.         myname = Dir
  25.     Loop
  26.     [a7].Resize(1, d.Count) = d.keys
  27. End Sub
复制代码

不重复字段标题.rar

37.48 KB, 下载次数: 18
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
grf1973
发表于 2014-6-11 09:43 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim filename, wb As Workbook, Sh As Worksheet
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     filename = Dir(ThisWorkbook.Path & "\*.xls")
  6.     Do While filename <> ""
  7.         If filename <> ThisWorkbook.Name Then
  8.             fn = ThisWorkbook.Path & "" & filename
  9.             Set wb = Workbooks.Open(fn)
  10.             For Each Sh In wb.Worksheets
  11.                 c = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column
  12.                 For j = 1 To c
  13.                     a = Sh.Cells(1, j).Value
  14.                     If Len(a) > 0 Then d(a) = ""
  15.                 Next
  16.             Next
  17.             wb.Close False
  18.         End If
  19.         filename = Dir
  20.     Loop
  21.     [a7].Resize(1, d.Count) = d.keys
  22.     Application.ScreenUpdating = True
  23. End SubSub 导入文件()
  24.     Application.ScreenUpdating = False
  25.     Dim filename, wb As Workbook, Sh As Worksheet
  26.     Set d = CreateObject("Scripting.Dictionary")
  27.     filename = Dir(ThisWorkbook.Path & "\*.xls")
  28.     Do While filename <> ""
  29.         If filename <> ThisWorkbook.Name Then
  30.             fn = ThisWorkbook.Path & "" & filename
  31.             Set wb = Workbooks.Open(fn)
  32.             For Each Sh In wb.Worksheets
  33.                 c = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column
  34.                 For j = 1 To c
  35.                     a = Sh.Cells(1, j).Value
  36.                     If Len(a) > 0 Then d(a) = ""
  37.                 Next
  38.             Next
  39.             wb.Close False
  40.         End If
  41.         filename = Dir
  42.     Loop
  43.     [a7].Resize(1, d.Count) = d.keys
  44.     Application.ScreenUpdating = True
  45. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-6-11 09:44 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
手抖了一下，粘贴了2次。。。。。。。。。。。
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim filename, wb As Workbook, Sh As Worksheet
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     filename = Dir(ThisWorkbook.Path & "\*.xls")
  6.     Do While filename <> ""
  7.         If filename <> ThisWorkbook.Name Then
  8.             fn = ThisWorkbook.Path & "" & filename
  9.             Set wb = Workbooks.Open(fn)
  10.             For Each Sh In wb.Worksheets
  11.                 c = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column
  12.                 For j = 1 To c
  13.                     a = Sh.Cells(1, j).Value
  14.                     If Len(a) > 0 Then d(a) = ""
  15.                 Next
  16.             Next
  17.             wb.Close False
  18.         End If
  19.         filename = Dir
  20.     Loop
  21.     [a7].Resize(1, d.Count) = d.keys
  22.     Application.ScreenUpdating = True
  23. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-6-11 09:53 | 显示全部楼层    本楼为最佳答案   
你自己的代码可参照修改。
  1. Sub 用选择文件夹的方式提取不重复字段标题()
  2.     Dim sh As Worksheet, arr, d As Object, i&, j&, MyPath$
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.             .InitialFileName = ThisWorkbook.Path & ""
  5.             If .Show = False Then Exit Sub
  6.             MyPath = .SelectedItems(1) & ""
  7.     End With
  8.    
  9.     Set d = CreateObject("Scripting.Dictionary")
  10.     myname = Dir(MyPath & "*.xls*") '获取xls*文件
  11.     Do While myname <> ""
  12.         If myname <> ThisWorkbook.Name Then '不包括本工作簿
  13.             With GetObject(MyPath & myname)
  14.                 For Each sh In .Worksheets '遍历工作表
  15.                 c = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
  16.                     For j = 1 To c
  17.                         a = sh.Cells(1, j).Value
  18.                         If Len(a) > 0 Then d(a) = ""
  19.                     Next
  20.                 Next
  21.                 .Close False
  22.             End With
  23.         End If
  24.         myname = Dir
  25.     Loop
  26.     [a7].Resize(1, d.Count) = d.keys
  27. End Sub
复制代码

评分

参与人数 1 +6 收起 理由
张雄友 + 6 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2014-6-11 18:04 | 显示全部楼层
本帖最后由 张雄友 于 2014-6-11 18:59 编辑
grf1973 发表于 2014-6-11 09:53
你自己的代码可参照修改。

上面是对某路径的工作表的第一行获取不重复标题字段，

现在要对某路径的工作表的A列获取不重复值。修改了，类型不匹配，烦请老师再次出手。
  1. Sub 用选择文件夹的方式提取A列不重复值()
  2.     Dim sh As Worksheet, arr, d As Object, i&, r&, MyPath$
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.             .InitialFileName = ThisWorkbook.Path & ""
  5.             If .Show = False Then Exit Sub
  6.             MyPath = .SelectedItems(1) & ""
  7.     End With
  8.    
  9.     Set d = CreateObject("Scripting.Dictionary")
  10.     myname = Dir(MyPath & "*.xls*") '获取xls*文件
  11.     Do While myname <> ""
  12.         If myname <> ThisWorkbook.Name Then '不包括本工作簿
  13.             With GetObject(MyPath & myname)
  14.                 For Each sh In .Worksheets '遍历工作表
  15.                 arr = sh.Range("A1:A" & sh.Range("A65536").End(3).Row)
  16.                       For i = 1 To UBound(arr)
  17.                    If Len(arr(i, 1)) Then d(arr(i, 1)) = ""
  18.                     Next
  19.                 Next
  20.                
  21.                 .Close False
  22.             End With
  23.         End If
  24.         myname = Dir
  25.     Loop
  26.     [A1].Resize(d.Count, 1) = d.keys
  27. End Sub
复制代码

跨表不重复.rar

39.17 KB, 下载次数: 5
回复

使用道具 举报

grf1973
发表于 2014-6-12 11:24 | 显示全部楼层
你把原来代码中排除空表的代码加上试试。我原先代码也用数组的，就是出现问题后才直接用单元格作为字典的key。应该是空表赋值数组出错。
回复

使用道具 举报

grf1973
发表于 2014-6-12 11:29 | 显示全部楼层
附件里代码可以的啊，运行无误。就最后要列输出时改成Application.Transpose(d.keys)
  1. Sub 用选择文件夹的方式提取A列不重复值()
  2.     [A1:A65536].ClearContents
  3.     Dim sh As Worksheet, arr, d As Object, i&, r&, MyPath$
  4.     With Application.FileDialog(msoFileDialogFolderPicker)
  5.             .InitialFileName = ThisWorkbook.Path & ""
  6.             If .Show = False Then Exit Sub
  7.             MyPath = .SelectedItems(1) & ""
  8.     End With
  9.     Application.ScreenUpdating = False
  10.     Set d = CreateObject("Scripting.Dictionary")
  11.     myname = Dir(MyPath & "*.xls*")
  12.     Do While myname <> ""
  13.         If myname <> ThisWorkbook.Name Then
  14.             With GetObject(MyPath & myname)
  15.                 For Each sh In .Worksheets
  16.                     If Application.CountA(sh.UsedRange) Then
  17.                         arr = sh.Range("A1:A" & sh.Range("A65536").End(3).Row)
  18.                         For i = 1 To UBound(arr)
  19.                             If Len(arr(i, 1)) Then d(arr(i, 1)) = ""
  20.                         Next
  21.                     End If
  22.                 Next
  23.                 .Close False
  24.             End With
  25.         End If
  26.         myname = Dir
  27.     Loop
  28.     [A1].Resize(d.Count, 1) = Application.Transpose(d.keys)
  29.     Application.ScreenUpdating = True
  30. End Sub
复制代码

评分

参与人数 1 +6 收起 理由
张雄友 + 6 很给力!

查看全部评分

回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-24 13:47 , Processed in 0.351995 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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