Excel VBA - 循环搜索

First, my code (below) works, but I am trying to see if it can be simplified. The macro in which this code is located will have a lot of specific search items and I want to make it as efficient as possible.

首先,我的代码(下面)有效,但我试图看看它是否可以简化。此代码所在的宏将包含许多特定的搜索项,我希望尽可能高效。

It is searching for records with a specific category (in this case "Chemistry") then copying those records into another workbook. I feel like using Activate in the search, and using Select when moving to the next cell are taking too much time and resources, but I don't know how to code it to where it doesn't have to do that.

它正在搜索具有特定类别的记录(在本例中为“Chemistry”),然后将这些记录复制到另一个工作簿中。我觉得在搜索中使用Activate,在移动到下一个单元格时使用Select会占用太多时间和资源,但我不知道如何将它编码到不必执行此操作的位置。

Here are the specifics:

以下是具体内容:

Search column T for "Chemistry"

在T列中搜索“Chemistry”

Once it finds "Chemistry", set that row as the "top" record. e.g. A65

一旦找到“Chemistry”,将该行设置为“top”记录。例如A65

Move to the next row down, and if that cell contains "Chemistry", move to the next row (the cells that contain "Chemistry" will all be together"

向下移动到下一行,如果该单元格包含“Chemistry”,则移至下一行(包含“Chemistry”的单元格将全部在一起“

Keep going until it doesn't find "Chemistry", then move up one row

继续前进,直到找不到“化学”,然后向上移动一行

Set that row for the "bottom" record. e.g. AX128

将该行设置为“底部”记录。例如AX128

Combine the top and bottom rows to get the range to select. e.g. A65:AX128

组合顶行和底行以获取要选择的范围。例如A65:AX128

Copy that range and paste it into another workbook

复制该范围并将其粘贴到另一个工作簿中

Here is the code:

这是代码:

'find "Chemistry"

Range("T1").Select

Cells.Find(What:="Chemistry", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate

'set top row for selection
toprow = ActiveCell.Row
topcellselect = "A" & toprow

'find all rows for Chemistry
Do While ActiveCell = "Chemistry"
ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Offset(-1, 0).Select

'set bottom row for selection
bottomrow = ActiveCell.Row
bottomcellselect = "AX" & bottomrow

'define selection range from top and bottom rows
selectionrange = topcellselect & ":" & bottomcellselect

'copy selection range
Range(selectionrange).Copy

'paste into appropriate sheet
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial

Thanks in advance for any help!

在此先感谢您的帮助!

2 个解决方案

#1

You never need to select or activate unless that's really what you want to do (at the end of the code, if you want the user to see a certain range selected). To remove them, just take out the activations and selections, and put the things on the same line. Example:

您永远不需要选择或激活,除非您真正想要做的事情(在代码的最后,如果您希望用户看到选定的某个范围)。要删除它们,只需取出激活和选择,然后将它们放在同一行。例:

wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial

Becomes

wb1.Sheets("Chemistry").Range("A2").PasteSpecial

For the whole code; I just loop thorugh the column and see where it starts and stops being "chemistry". I put it in a Sub so you only have to call the sub, saying which word you're looking for and where to Paste it.

对于整个代码;我只是循环通过柱子,看看它开始的地方,并停止“化学”。我把它放在一个Sub中,所以你只需要调用sub,说出你要查找的单词以及粘贴它的位置。

Sub tester
    Call Paster("Chemistry", "A2")
End sub

Sub Paster(searchWord as string, rngPaste as string)
    Dim i as integer
    Dim startRange as integer , endRange as integer
    Dim rng as Range

    With wb1.Sheets("Chemistry")

        For i = 1 to .Cells(Rows.Count,20).End(XlUp).Row
            If .Range("T" & i ) = searchWord  then 'Here it notes the row where we first find the search word
                startRange = i
                Do until .Range("T" & i ) <> searchWord 
                    i = i + 1 'Here it notes the first time it stops being that search word
                Loop
                endRange = i - 1 'Backtracking by 1 because it does it once too many times
                Exit for
            End if
        Next


        'Your range goes from startRange to endRange now
        set rng = .Range("T" & startRange & ":T" & endRange)

        rng.Copy

        .Range(rngPaste).PasteSpecial 'Paste it to the address you gave as a String

    End with
End sub

As you can see I put the long worksheet reference in a With to shorten it. If you have any questions or if it doesn't work, write it in comments (I haven't tested)

正如您所看到的,我将长工作表引用放在With中以缩短它。如果您有任何问题或者它不起作用,请在评论中写下(我还没有测试过)

#2

The most efficient way is to create a Temporary Custom Sort Order and apply it to your table.

最有效的方法是创建临时自定义排序顺序并将其应用于您的表。

Sub MoveSearchWordToTop(KeyWord As String)
    Dim DestinationWorkSheet As Workbook

    Dim SortKey As Range, rList As Range

    Set SortKey = Range("T1")

    Set rList = SortKey.CurrentRegion
    Application.AddCustomList Array(KeyWord)


    rList.Sort Key1:=SortKey, Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    Application.DeleteCustomList Application.CustomListCount

    Set DestinationWorkSheet = Workbooks("Some Other Workbook.xlsx").Worksheets("Sheet1")

    rList.Copy DestinationWorkSheet.Range("A1")

End Sub

#1

wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial