[已解决]如何实现从外部选择文件的方式把这三张表的单词提取进来呢？

jessylake · 发表于 2014-9-1 21:18

在附件中有三个表：07、36、60，如果这三张表分别位于三个excel文件中，而且都是位于sheet1表，名称还是07、36、60，那么如何实现从外部选择这三个文件的方式把这三张表的单词提取进来呢？

提取单词 .zip (27.99 KB, 下载次数: 3)

dsmch · 发表于 2014-9-1 21:46

Sub Macro1()
Dim mypath$$, wb As Workbook, wj$$, d
Dim arr, brr(1 To 60000, 1 To 3), j&, k%, s&
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
mypath = ThisWorkbook.Path & ""
wj = Dir(mypath & "*.xls")
Do While wj <> ""
If wj <> ThisWorkbook.Name Then
Set wb = GetObject(mypath & wj)
arr = wb.Sheets(1).UsedRange
wb.Close 0
For j = 2 To UBound(arr) Step 2
For k = 1 To UBound(arr, 2)
If arr(j, k) <> "" And Not d.exists(arr(j, k)) Then
d(arr(j, k)) = arr(j + 1, k): s = s + 1: brr(s, 1) = arr(j, k): brr(s, 2) = arr(j + 1, k)
End If
If j = 2 And k = 1 Then brr(s, 3) = arr(1, 1)
Next
Next
End If
wj = Dir
Loop
ActiveSheet.UsedRange.ClearContents
Range("a1").Resize(s, 3) = brr
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2014-9-1 21:47

………………

jessylake · 发表于 2014-9-1 21:57

dsmch 发表于 2014-9-1 21:47
………………

不过有个地方需要改进一下，点击按钮能不能让我来从目录中选择文件，再提取，我加这个功能是想，随时增加词库，挑选我希望增加的单词表

dsmch · 发表于 2014-9-2 02:01

Sub Macro1()
Dim wb As Workbook, d, i%, j&, k%, s&
Dim arr, brr(1 To 60000, 1 To 3)
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
For i = .SelectedItems.Count To 1 Step -1
Set wb = GetObject(.SelectedItems(i))
arr = wb.Sheets(1).UsedRange
wb.Close 0
For j = 2 To UBound(arr) Step 2
For k = 1 To UBound(arr, 2)
If arr(j, k) <> "" And Not d.exists(arr(j, k)) Then
d(arr(j, k)) = arr(j + 1, k): s = s + 1: brr(s, 1) = arr(j, k): brr(s, 2) = arr(j + 1, k)
End If
If j = 2 And k = 1 Then brr(s, 3) = arr(1, 1)
Next
Next
Next
End With
ActiveSheet.UsedRange.ClearContents
Range("a1").Resize(s, 3) = brr
Application.ScreenUpdating = True
End Sub

复制代码

jessylake · 发表于 2014-9-2 06:28

本帖最后由 jessylake 于 2014-9-2 08:57 编辑

dsmch 发表于 2014-9-2 02:01

真是过意不去，让老师这么晚还在写代码，真是辛苦了，这段代码真是令人难以置信，太棒了，希望老师再做点改动，就是导入的时候能够按照文件选择的顺序，由上到下排列单词，现在是反着的，第一个选择的单词表文件中的单词排在最后面；还有选择文件的窗口，如果点击取消，会出错，并且把原来导入的数据删除。再次对老师表示感谢！

这两个问题我自己改了一下，解决了：
Sub Macro1()
Dim wb As Workbook, d, i%, j&, k%, s&
Dim arr, brr(1 To 60000, 1 To 3)
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
If .SelectedItems.Count = 0 Then Exit Sub
For i = 1 To .SelectedItems.Count
      Set wb = GetObject(.SelectedItems(i))
      arr = wb.Sheets(1).UsedRange
      wb.Close 0
      For j = 2 To UBound(arr) Step 2
         For k = 1 To UBound(arr, 2)
            If arr(j, k) <> "" And Not d.exists(arr(j, k)) Then
                  d(arr(j, k)) = arr(j + 1, k): s = s + 1: brr(s, 1) = arr(j, k): brr(s, 2) = arr(j + 1, k)
            End If
            If j = 2 And k = 1 Then brr(s, 3) = arr(1, 1)
         Next
      Next
Next
End With
ActiveSheet.UsedRange.ClearContents
Range("a1").Resize(s, 3) = brr
Application.ScreenUpdating = True
End Sub

不过还有个比较关键的问题，就是现在导入新表会把原来导入的单词全部清空，如何从最下面导入新表？
自己又改好了：
Sub Macro1()
Dim wb As Workbook, d, i%, j&, k%, s&, Myr&
Dim arr, brr(1 To 60000, 1 To 3)
Application.ScreenUpdating = False
Myr = IIf([a1] = "", 1, Sheet1.[a1].End(xlDown).Row)
Set d = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
If .SelectedItems.Count = 0 Then Exit Sub
For i = 1 To .SelectedItems.Count
      Set wb = GetObject(.SelectedItems(i))
      arr = wb.Sheets(1).UsedRange
      wb.Close 0
      For j = 2 To UBound(arr) Step 2
         For k = 1 To UBound(arr, 2)
            If arr(j, k) <> "" And Not d.exists(arr(j, k)) Then
                  d(arr(j, k)) = arr(j + 1, k): s = s + 1: brr(s, 1) = arr(j, k): brr(s, 2) = arr(j + 1, k)
            End If
            If j = 2 And k = 1 Then brr(s, 3) = arr(1, 1)
         Next
      Next
Next
End With
Range("a" & Myr).Resize(s, 3) = brr
Application.ScreenUpdating = True
End Sub

但还是有个问题，如果导入的表是重名（以表中的标题栏为准）的，如何实现只是对已导入的单词库中同名（即第三列相同，所以可能第三列都需要加标题栏，现在仅是表中第一个单词加）的部分进行更新，当然可能导入的同名表中的单词数量可能增加或减少，这怎么更新呢？

还有，Application.FileDialog(msoFileDialogOpen) 怎么设置默认文件是 excel文件？（好像有记忆功能，不用改了）  Set wb = GetObject(.SelectedItems(i))
应该是打开文件，如果打开失败，比如让输入密码，我点取消，如何避免错误提示（287错误：应用程序定义或对象定义错误）？（解决了，用 On error goto 可以跳过去，直接结束）  就剩下导入重名表的更新问题了，呵呵，这个要靠老师了

dsmch · 发表于 2014-9-2 19:27

用选择数据源文件夹方法试试，数据源文件夹可以不断更新增加，手动选择也较方便

jessylake · 发表于 2014-9-2 19:54

dsmch 发表于 2014-9-2 19:27
用选择数据源文件夹方法试试，数据源文件夹可以不断更新增加，手动选择也较方便

测试了一下，确实可以更新，但是前提必须是文件名必须一致，不是根据C列的内容判断进行的，是整个所有表都重新走一遍，如果表多的话，更新起来比较慢了，不是对某一张表进行更新，增加一张新表，实际上也是把所有表都提取一遍

jessylake · 发表于 2014-9-2 20:18

dsmch 发表于 2014-9-2 19:27
用选择数据源文件夹方法试试，数据源文件夹可以不断更新增加，手动选择也较方便

针对C列标题栏名称，只对个别的表进行更新词库不好实现吗

jessylake · 发表于 2014-9-2 21:18

dsmch 发表于 2014-9-2 19:27
用选择数据源文件夹方法试试，数据源文件夹可以不断更新增加，手动选择也较方便

那您为什么不用5楼的方法做一个，像我新发的帖子：请求数组高手利用导入外部单词表文件帮我把词库进行更新或补充
http://www.excelpx.com/thread-331179-1-1.html 所希望的？是不是有难度呀，可我总得，好像也不是很难吧，我的思路是通过C列找到原表单词所占的单元格区域，然后用新表里的单词组成的数组赋值到这个区域里，不就OK了，呵呵，可惜我这个外行，不懂数组不会写代码，最近刚开始学

		自动登录	找回密码
密码			注册

[已解决]如何实现从外部选择文件的方式把这三张表的单词提取进来呢？

点评

点评

点评

点评