通过关键字（公司名称）例如：2222 ，去搜索，获取多行多列的新表，现在这个只能获...

gwjkkkkk

Private Sub CommandButton1_Click()
    Dim Rng As Range, rngFind As Range, strFirstAddress$
    Dim ar(), i&, iRow
    If Me.TextBox1.Value = "" Then Exit Sub
    If Me.TextBox2.Value = "" Then Exit Sub
   
    Set Rng = Range([A1], ActiveSheet.UsedRange)
    If Val(Me.TextBox1.Value) > Rng.Columns.Count Then
        MsgBox "超出范围": Exit Sub
    End If
   
    Application.DisplayAlerts = False
   
    Set Rng = Rng.Columns(Val(Me.TextBox1.Value))
    Set rngFind = Rng.Find(Me.TextBox2.Value, , , xlWhole)
    If Not rngFind Is Nothing Then
        strFirstAddress = rngFind.Address
        Do
            r = r + 1
            ReDim Preserve ar(1 To r)
            Set ar(r) = rngFind.CurrentRegion
            Set rngFind = Rng.FindNext(rngFind)
        Loop Until rngFind.Address = strFirstAddress
    End If
   
    If r = 0 Then
        MsgBox "没找到"
        Else
            On Error Resume Next
                Worksheets(Me.TextBox2.Value).Delete
            On Error GoTo 0
            With Worksheets.Add(after:=Worksheets(Worksheets.Count))
                .Name = Me.TextBox2.Value
                iRow = 1
                For i = 1 To UBound(ar)
                    ar(i).Copy Cells(iRow, 1)
                    iRow = iRow + ar(i).Rows.Count + 1
                Next i
                .UsedRange.Columns.AutoFit
            End With
        Unload Me
    End If
   
    Set Rng = Nothing: Set rngFind = Nothing
    Application.DisplayAlerts = True
End Sub

gwjkkkkk

wwl44 发表于 2024-3-7 14:32
目前是这样

根据你的模拟结果重新写了一下。。。

wwl44

gwjkkkkk 发表于 2024-3-7 19:53
根据你的模拟结果重新写了一下。。。

感谢大神，完美的解决了我的问题