Excel VBA macros не находит соответствий

Question

У меня есть макросстройка в книге Excel; его целью является: 1. В Sheet1 для поиска таблицы для определенного значения в столбце. 2. Если это значение найдено, оно должно скопировать всю строку в Sheet2.

Sub procurarnegociacion() 

Dim LSearchRow As Integer 
Dim LCopyToRow As Integer 

On Error GoTo Err_Execute 

'Start search in row 5 
LSearchRow = 5 

'Start copying data to row 3 in Sheet2 (row counter variable) 
LCopyToRow = 3 

While Len(Range("A" & CStr(LSearchRow)).Value) > 0 

    'If value in column W = 1, copy entire row to Sheet2 
    If Range("W" & CStr(LSearchRow)).Value = "1" Then 

     'Select row in Sheet1 to copy 
     Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
     Selection.Copy 

     'Paste row into Sheet2 in next row 
     Sheets("Sheet2").Select 
     Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select 
     ActiveSheet.Paste 

     'Move counter to next row 
     LCopyToRow = LCopyToRow + 1 

     'Go back to Sheet1 to continue searching 
     Sheets("Sheet1").Select 

    End If 

    LSearchRow = LSearchRow + 1 


Wend 

'Position on cell A3 
Application.CutCopyMode = False 
Range("A3").Select 

MsgBox "All data copied." 

Exit Sub 

Err_Execute: 
MsgBox "Error ocurred." 

End Sub 

Но вот проблема: представьте себе, я искать значение «5», и у меня есть только 1-5 значений в этом столбце В. Макрос работает только если у меня есть все 5 отсортирован в начале таблицы (сортировка потомков). Если у меня есть столбец W в форме полумесяца, со всеми 1-м первым, то он не копирует ни одну строку в Sheet2. Это дает сообщение Все данные скопированы. ", Но ни одна строка не копируется на Лист2.

Почему это? Можете ли вы помочь мне с этим вопросом?

Answer 1

Это слегка измененный вариант, кажется, работает для меня , даже если данные не отсортированы. вы можете иметь проблемы с расстояния qualfication, или если вы работаете, пока Sheet2 активен он не может ничего копировать, как и ожидалось, и т.д.

Sub procurarnegociacion() 

Dim LSearchRow As Integer 
Dim LCopyToRow As Integer 
Dim source As Worksheet 
Dim dest As Worksheet 

On Error GoTo Err_Execute 

Set source = Worksheets("Sheet1") 'Modify as needed 
Set dest = Worksheets("Sheet2")  'Modify as needed 

'Start search in row 5 
LSearchRow = 5 

'Start copying data to row 3 in Sheet2 (row counter variable) 
LCopyToRow = 3 

With source 
    While Len(.Range("A" & CStr(LSearchRow)).Value) > 0 

     'If value in column W = 1, copy entire row to Sheet2 
     If .Range("W" & CStr(LSearchRow)).Value = "5" Then 

      'Select row in Sheet1 to copy 
      .Rows(LSearchRow).EntireRow.Copy _ 
       Destination:=dest.Rows(LCopyToRow) 

      'Move counter to next row 
      LCopyToRow = LCopyToRow + 1 
     End If 

     LSearchRow = LSearchRow + 1 
    Wend 
    'Position on cell A3 
    Application.CutCopyMode = False 
    .Range("A3").Select 
End With 

MsgBox "All data copied." 

Exit Sub 

Err_Execute: 
MsgBox "Error ocurred." 

End Sub