求助数组高手帮我把这几张英语单词表中的单词改变排列顺序

renahu

通过点击“提取单词”按钮依次将sheet1右边的3张单词表（实际有六十多张）中的单词按照“一行一行”的顺序把“英语单词”和对应的“中文意思”分别按纵向，首尾相接地放入sheet1的A列和B列中。单词表可能不完整，其中还有合并单元格。另外在每个单词表中的单词提取过来后，在首个单词的C列写入该单词表的标题，如“英语单词表（七）”，这样做的最终目的是想利用excel的“字典”功能快速查找英语单词。详见附件：
提取单词.rar (57.64 KB, 下载次数: 9)

2014-8-31 06:59 上传

点击文件名下载附件

TomingTang

我改了一下汇总工作表“sheet1”的工作表名为“汇总”，因为当用sheet1，程序出错，我还不知道什么原因。
你看看行不，我初步看没有问题，仔细看就没有了

1. Sub 汇总()
   
2.     Dim drow1%, drow2%, i%, j%, dcol%, k%, Arr, Brr(1 To 1000, 1 To 3)
   
3.     Dim sht As Worksheet
   
4.     For Each sht In ThisWorkbook.Worksheets
   
5.         If sht.Name <> "汇总" Then
   
6.             With sht
   
7.                 drow1 = .[a65536].End(3).Row
   
8.                 dcol = .Range("XFD2").End(xlToLeft).Column
   
9.                 Arr = .Range(.Cells(1, 1), .Cells(drow1, dcol))
   
10.             End With
    
11.             Brr(1, 3) = Arr(1, 1)
    
12.             k = 1
    
13.             For i = 2 To drow1 Step 2
    
14.                 For j = 1 To dcol Step 2
    
15.                     If Arr(i, j) <> 0 Then
    
16.                         Brr(k, 1) = Arr(i, j)
    
17.                         Brr(k, 2) = Arr(i + 1, j)
    
18.                         k = k + 1
    
19.                     End If
    
20.                 Next
    
21.             Next
    
22. 
    
23.             With Worksheets("汇总")
    
24.                 drow2 = .[a65536].End(3).Row
    
25.                 .Cells(drow2 + 1, 1).Resize(UBound(Brr), 3) = Brr
    
26.             End With
    
27.             Erase Brr
    
28.         End If
    
29.     Next sht
    
30.     MsgBox "汇总完成"
    
31. End Sub
    

复制代码

renahu

TomingTang 发表于 2014-8-31 08:18
我改了一下汇总工作表“sheet1”的工作表名为“汇总”，因为当用sheet1，程序出错，我还不知道什么原因。
...

首先表示非常感谢，初步看了一下，发些一些重复的，不知道怎么回事？

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, Brr(1 To 50000, 1 To 3), n&
   
3. Dim Sht As Worksheet, nm$, d
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For Each Sht In Sheets
   
6.     If Sht.Name <> "Sheet1" Then
   
7.         Arr = Sht.[a1].CurrentRegion
   
8.         nm = Sht.[a1].Value
   
9.         For i = 2 To UBound(Arr) Step 2
   
10.             For j = 1 To UBound(Arr, 2)
    
11.                 If Arr(i, j) <> "" Then
    
12.                     If Not d.exists(Arr(i, j)) Then
    
13.                     d(Arr(i, j)) = ""
    
14.                     n = n + 1
    
15.                     Brr(n, 1) = Arr(i, j)
    
16.                     Brr(n, 2) = Arr(i + 1, j)
    
17.                     Brr(n, 3) = nm
    
18.                     End If
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End If
    
23. Next
    
24. Sheet1.Activate
    
25. [a:c].ClearContents
    
26. [a1].Resize(n, 3) = Brr
    
27. End Sub
    

复制代码

蓝桥玄霜

请见附件。

zax010

Sub zz()
    Dim arr, sh As Worksheet, brr, d
    Set d = CreateObject("Scripting.Dictionary")
    ReDim brr(1 To 50000, 1 To 3)
    For Each sh In Sheets
        If sh.Name <> "Sheet1" Then
            arr = sh.UsedRange
            If m = 0 Then brr(1, 3) = arr(1, 1)
            If m <> 0 Then brr(m + 1, 3) = arr(1, 1)
            For i = 3 To UBound(arr) Step 2
                For j = 1 To UBound(arr, 2)
                    If arr(i, j) <> "" And Not d.exists(arr(i - 1, j)) Then
                        m = m + 1
                        brr(m, 1) = arr(i - 1, j)
                        brr(m, 2) = arr(i, j)
                        d(arr(i - 1, j)) = ""
                    End If
                Next
            Next
        End If
    Next
    Sheet1.[a1].Resize(m, 3) = brr
End Sub

renahu

蓝桥玄霜 发表于 2014-8-31 09:28
请见附件。

还是老师厉害，终于不重复了，是什么原因呢？

zax010

>>>>>>>>>>>>>
提取单词.rar (65.93 KB, 下载次数: 24)

2014-8-31 09:40 上传

点击文件名下载附件

renahu

zax010 发表于 2014-8-31 09:40
>>>>>>>>>>>>>

非常感谢，字体大小还能随单元格长度变化，有特色，就是第一个表中的单词 bottom 多出一空格，不知怎么回事？

zax010

renahu 发表于 2014-8-31 10:01
非常感谢，字体大小还能随单元格长度变化，有特色，就是第一个表中的单词 bottom 多出一空格，不知怎么回 ...

第一表D9单元格有一个“底”字。