求教大神，关于转置的问题

arnoldlx84

Sub 数组查询()
    Dim i%, n%, m%
    Dim a$, gjz$
    Dim arr, arr1()
    Dim sht As Worksheet, sht1 As Worksheet, sht2 As Worksheet
    Dim wb As Workbook

    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wb = Workbooks.Open(ThisWorkbook.Path & "\测试.xlsx")
    Set sht = wb.Sheets("数据库")
    Set sht1 = ThisWorkbook.Worksheets("A")
    Set sht2 = ThisWorkbook.Worksheets("输入界面")

    sht1.[a2:l1000].ClearContents
    arr = sht.[a2:l800]
    gjz = "*" & sht2.[I10].Value & "*"


    For i = 1 To UBound(arr)
        a = Join(Array(arr(i, 3)))
        If a Like gjz Then
            m = m + 1
            ReDim Preserve arr1(1 To 12, 1 To m)

            arr1(1, m) = arr(i, 1)
            arr1(2, m) = arr(i, 2)
            arr1(3, m) = arr(i, 3)
            arr1(4, m) = arr(i, 4)
            arr1(5, m) = arr(i, 5)
            arr1(6, m) = arr(i, 6)
            arr1(7, m) = arr(i, 7)
            arr1(8, m) = arr(i, 8)
            arr1(9, m) = arr(i, 9)
            arr1(10, m) = arr(i, 10)
            arr1(11, m) = arr(i, 11)
            arr1(12, m) = arr(i, 12)
        End If

    Next

    sht1.[a2].Resize(m, 12) = Application.Transpose(arr1)
    rem 如果将其改为 ht1.[a2].Resize(m, 12) = arr1 则可以正常显示，但行列式颠倒的。进行转置以后却不能够正常显示。行数大概在1000行左右，列数12列




    wb.Close 0
    Erase arr
    Erase arr1

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

hfwufanhf2006

没啥问题啊，我测试可以通过的。
就是你代码写的太啰嗦了。中间两个数组相互对倒完全是多余，找到一个符合条件单元格的同时立即在工作表中填一行对应数据还能节省一个数组。

arnoldlx84

谢谢，初学者，见谅见谅。能否提供一下代码，让我学习一下。
但是，我这边运行后就是不能够显示出来，很奇怪

hfwufanhf2006

arnoldlx84 发表于 2019-7-5 11:16
谢谢，初学者，见谅见谅。能否提供一下代码，让我学习一下。
但是，我这边运行后就是不能够显示出来，很奇 ...

比较简短点的代码就像下面这样的，代码放在第一个表“数据库”，后面有解释：
Worksheets("A").[a2:l1000].ClearContents
arr = [a2:l800]
gjz = "*" & Worksheets("输入界面").[I10].Value & "*"
hs = 2
For i = 1 To 800
    If Cells(i, 3) Like gjz Then
       For k = 1 To 12
           Worksheets("A").Cells(hs, k) = Cells(i, k)
       Next k
       hs = hs + 1
    End If
Next i


解释：
1、关于工作表的引用，可以用worksheet对象，也可直接用表名。对于你这个，直接用表名更简单，所以代码里所有工作表对象定义都被我删掉了；
2、关于当前工作表与非当前工作表：
    当前工作表就是代码所在的表，也是鼠标看得见的表，因为在执行代码的时候，只有看得见的表才能执行代码；
    其他看不见的所有表都是非当前工作表，这与窗口是类似的，最上层看得见的窗体具有焦点，曡在后面的窗体都不能操作；
    差别：当前工作表可以省略工作表前缀，非当前工作表不能省略，所以你能看到对单元格的引用有两种，比如：
             Worksheets("A").Cells(hs, k) = Cells(i, k)
             这是把结果从“数据库”写入到工作表“A”中，因为代码在“数据库”中，“数据库”就是当前工作表，所以等号后面的Cells(i, k)就可以省略“数据库”这个前缀，但等号左边的工作表“A”就不能省略，需要写成完整的Worksheets("A").Cells(hs, k)；
3、单元格的引用有两种：range和cells，对于一个明确固定的单元格或区域，使用range，比如range("i10")，对于循环中的单元格引用，help推荐用cells，因为cells(x,y)刚好与循环参数搭配，所以有：
       For k = 1 To 12   '循环12次，依次写入一行的12列数据，从第一列到第12列，也就是a到I列
           Worksheets("A").Cells(hs, k) = Cells(i, k)    '读和写是同步的，并不需要分开
       Next k

       还能节省数组；
4、关于数组和单元格引用的速度差异：
     数组的速度要远远高于直接对单元格的引用速度，但是有前提的：
        1）当需要在某个区域反复查询时用数组，数组会极大提高速度；
        2）当一次性顺序查询区域时，直接用单元格，因为把单元格区域的数据写入数组也是要花时间的，这个时间与直接引用单元格一次所花费的时间相等，多次反复才能节省时间。你的例子是一次性浏览一遍就能判断出来了，所以数组也是多余的；

arnoldlx84

万分感谢，学习到了，大神。
我目前在自学关于数组和字典，能否请您也利用这个例子，分别写一下字典和数组，一样功能性的代码，让我有的比较学习，这样可能理解会更快一些。
感谢大神解惑。

hfwufanhf2006

arnoldlx84 发表于 2019-7-5 15:36
万分感谢，学习到了，大神。
我目前在自学关于数组和字典，能否请您也利用这个例子，分别写一 ...

1、数组，象下面这样的替换下代码就行：
Worksheets("A").[a2:l1000].ClearContents
Dim arr
arr = [a2:l800]
gjz = "*" & Worksheets("输入界面").[I10].Value & "*"
hs = 2
For i = 2 To 800
    If arr(i - 1, 3) Like gjz Then    '数据已全部装入数组，直接用数组比较。注意下标，因为从第2行开始，装入数组的下标1，所以要i-1
       For k = 1 To 12
           Worksheets("A").Cells(hs, k) = arr(i - 1, k)    '读取数组的内容
       Next k
       hs = hs + 1
    End If
Next i


2、字典，你这个例子不太适合用字典，字典是去重的，你的例子是如果源数据匹配 I10 单元格的，全部输出到“A"表，I10只有一个值，那么也意味着字典也只能存储一个值，因为不管有多少重复的I10值，字典都只能保存一个。
   下面是字典代码，但只能返回最后一个符合 I10 的行，前面重复的都被字典自动替换了。这段代码虽然没意义，但有个一对多的技巧：
Worksheets("A").[a2:l1000].ClearContents
Dim zd
Set zd = CreateObject("scripting.dictionary")
Dim arr(1 To 12)
For i = 2 To 800     '把源数据写入字典
    For k = 1 To 12
        arr(k) = Cells(i, k)   '先写到数组，这样可以形成一对多。如果没有数组，一个字典key就只能存储一个值，这里存储的是数组，共12个值
    Next k
    zd(Cells(i, 3).Value) = arr  '把数组的12列写入字典，这样的字典就是一对多
Next i
gjz = "*" & Worksheets("输入界面").[I10].Value & "*"
Dim arr1
arr1 = zd.keys    '读取字典key
hs = 2
For i = 0 To UBound(arr1)
    If arr1(i) Like gjz Then    '比如 I10="aaa" ,那么只有类似 ”aaa"、“aaaa”、"qqaaadd"、"123aaa"这样含有aaa字符的才能读出来
       Worksheets("A").Range(Worksheets("A").Cells(hs, 1), Worksheets("A").Cells(hs, 12)) = zd(arr1(i))  '结果只有一行或少数几行，大部分会漏掉
        '填充一行，连续的列可以一次填充，不连续的不能
       hs = hs + 1
    End If
Next i

arnoldlx84

大神，万分感谢。