输入某关键字，提取该关键字同列单元格中所有下一行的整行数据到新表

wjh69

蓝桥玄霜 发表于 2018-3-2 10:22
请见代码。

老师看看怎么提示"方法和数据找不到"

蓝桥玄霜

请仔细核对抄写的代码，初学者常常会抄错的。
建议上传出错的代码和附件看看。

wjh69

蓝桥玄霜 发表于 2018-3-3 11:25
请仔细核对抄写的代码，初学者常常会抄错的。
建议上传出错的代码和附件看看。

捕获.PNG (1032×493) file:///C:/Users/Administrator/Pictures/%E6%8D%95%E8%8E%B7.PNG
是命令按钮无链接代码？

wjh69

代码应该没有抄错吧

wjh69

Private Sub commandbuttonl_click()
Dim col%, gjz$
Dim arr, i&, aa, j&
Dim d, k, t
col = Val(Me.TextBox1.Text)
gjz = Me.TextBox2.Text
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
If col > UBound(arr, 2) Or col < 0 Then MsgBox "列超出范围！": Exit Sub
If gjz = "" Then MsgBox "关键字不能为空！": Exit Sub
For i = 1 To UBound(arr)
    If arr(i, col) = gjz Then d(gjz) = d(gjz) & i & ","
    End If
Next
If d.Count > 0 Then
    Sheet.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = gjz
        k = d.keys: t = d.items
        For i = 0 To UBound(k)
            t(i) = Left(t(i), Len(t(i)) - 1)
            If InStr(t(i), ",") Then
                aa = Split(t(i), ",")
                For j = 0 To UBound(aa)
                    .Cells(j + 2, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, aa(j), 0)
                Next
            Else
                .Cells(2, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, t(i), 0)
            End If
        Next
    End With
End If
Unload Me
End Sub

Private Sub UserForm_Click()

End Sub

wjh69

蓝桥玄霜 发表于 2018-3-3 11:25
请仔细核对抄写的代码，初学者常常会抄错的。
建议上传出错的代码和附件看看。

Private Sub commandbuttonl_click()
Dim col%, gjz$
Dim arr, i&, aa, j&
Dim d, k, t
col = Val(Me.TextBox1.Text)
gjz = Me.TextBox2.Text
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion
If col > UBound(arr, 2) Or col < 0 Then MsgBox "列超出范围！": Exit Sub
If gjz = "" Then MsgBox "关键字不能为空！": Exit Sub
For i = 1 To UBound(arr)
    If arr(i, col) = gjz Then d(gjz) = d(gjz) & i & ","
    End If
Next
If d.Count > 0 Then
    Sheet.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = gjz
        k = d.keys: t = d.items
        For i = 0 To UBound(k)
            t(i) = Left(t(i), Len(t(i)) - 1)
            If InStr(t(i), ",") Then
                aa = Split(t(i), ",")
                For j = 0 To UBound(aa)
                    .Cells(j + 2, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, aa(j), 0)
                Next
            Else
                .Cells(2, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, t(i), 0)
            End If
        Next
    End With
End If
Unload Me
End Sub

Private Sub UserForm_Click()

End Sub

wjh69

蓝桥玄霜 发表于 2018-3-3 11:25
请仔细核对抄写的代码，初学者常常会抄错的。
建议上传出错的代码和附件看看。

蓝老师，您测试没有问题吗？，我知道您为我好，让我多动手学习，我鼓捣了半天还是这样，命令按钮无反应，要不您把您测试好的附件发到我邮箱，我仔细比较一下，看我哪里搞错了。

wjh69

2120825479@qq.com

蓝桥玄霜

第一句就抄错了，大小写这里不能错，
第一个循环中少了一句；
Sheets.Add少了个s
请见附件。

wjh69

蓝桥玄霜 发表于 2018-3-4 09:47
第一句就抄错了，大小写这里不能错，
第一个循环中少了一句；
Sheets.Add少了个s

蓝老师，我用Excel2016和WPS2016运行刚发的附件，提示下标越界，怎么回事