VBA for cut Данные для определенных ключевых слов

Question

Я хочу, чтобы данные обрезания из A1: D10000 для определенного ключевого слова. Пример, если есть строка с «Дата выпуска: \ n», она будет вырезана & вставить соответствующую ячейку в столбец F. Я имею в виду, если любая строка имеет с «Дата выпуска: \ п» в С21, то он будет разрезать & пасту F21

У меня есть код & он работает отлично. Но проблема в том, что для завершения требуется огромное время, чем я ожидал. Любой лучший код, как будто он работает быстро?

Мой код:

Sub Macro87()

For Repeat = 1 To 10000 
Dim found As Range 
Sheets("part15").Select 
Range("A1").Select 
Columns("A:D").EntireColumn.Select 
Set found = Selection.Find(What:="Release Date:\n ", After:=ActiveCell, LookIn:= _ 
    xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ 
    , MatchCase:=False, SearchFormat:=False) 

If Not found Is Nothing Then 
found.Select 
ActiveCell.Select 
Selection.Cut 
Range("F" & (ActiveCell.Row)).Select 
ActiveSheet.Paste 
Set found = Nothing 
End If 
Next 

End Sub 

Answer 1

Как отметил Дэйв, большая часть вашего замедления будет поступать из повторяющихся операторов выбора в вашем коде. VBA обычно не нужно выбирать диапазон, чтобы работать с данными в нем. Следующее должно ускорить процесс для вас совсем немного. Она работает для меня мгновенно:

Sub Macro87() 
    Set Rng = Range("A1:D10000") 
    For Each cel In Rng 
     If InStr(1, cel.Value, "Release Date:\n ") > 0 Then 
      Cells(cel.Row(), 6) = cel.Value 
      cel.Value = Empty 
     End If 
    Next cel 
End Sub 

Answer 2

Во-первых, остановка происходит от 1 до 10000 - вам не нужно повторять действия так много, когда вы можете использовать вместо .FindNext. Во-вторых, избегайте, как чума, использования .Select.

Dim ws as Worksheet 
Set ws = ThisWorkbook.Worksheets("part15") 
Dim lastRow 
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 

Dim found As Range 
With ws.Range("A:D") 
    Set found = .Find(What:="Release Date:\n ", After:=ActiveCell, LookIn:= _ 
    xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _ 
    , MatchCase:=False, SearchFormat:=False) 

    If Not found Is Nothing Then 
     firstAddress = found.Address 
     Do 
      ws.Range("F" & found.Row).Value = found.Value 
      set found = .FindNext(found) 
     Loop While Not found Is Nothing And found.Address <> firstAddress 
    End If 
End With 

End Sub