Переместить строки с ячейкой определенного значения с одного листа на другой в той же книге

Работаем на листе под названием Open. Как только у нас появится значение формулы, показывающее, что установка завершена, ячейки в этой строке будут перемещены во второй столбец первой доступной строки на другом листе. (Мы помещаем номер месяца в первый столбец.)

Sub MoveUsingOneWord()
Dim strSearch As String, EndRw As Long, Rw As Long

' The line below means: come up from the bottom of the sheet to the last empty cell in column A and use that
EndRw = Cells(Rows.Count, "A").End(xlUp).row
strSearch = "Complete"

' The line below means: ignore #N/A errors hopefully
On Error Resume Next

For Rw = 2 To EndRw
    If InStr(Cells(Rw, "A").Value, SrchTerm) Then

        ' The letter A in line below is the first of the rows you want to move
        ' The number 7 in line below is how many cells you want to move, 7 is a test & live will be 32 per row
        With Cells(Rw, "A").Resize(, 7)
            .Copy Sheets("Billed or Cancelled").Cells(Rows.Count, "B").End(xlUp)(2)
        .Delete Shift:=xlUp
        End With
        Rw = Rw - 1
    End If
Next Rw
End Sub

До тех пор, пока не будут введены номер счета-фактуры и дата получения, в ячейке отображается ошибка #N/A, следовательно, возобновляется следующая запись. Как только они будут введены, появится сообщение «Завершено».

По большей части он работает так, как я и предполагал, за исключением того, что перемещает все ячейки из всех строк.

Вы не используете strSearch, а что такое SrchTerm?

— 20.05.2024 15:39

При удалении строк следует выполнять цикл снизу вверх, чтобы удаление не мешало вашей обработке. For Rw = EndRw To 2 Step -1

— 20.05.2024 19:09

Спасибо вам обоим за ваше время и помощь с этим Черным котом и Тимом Уильямсом, я обновлю команду поиска и исправлю цикл, как было предложено.

— 21.05.2024 08:59

excel vba

20.05.2024 15:34

Преобразование HTML-таблицы в профессиональный документ Excel

Это самый простой способ создания Excel из HTML-таблицы.

Импорт excel в laravel в базу данных

Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...

Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Переместить совпадающие строки

Sub MoveCompletedInvoices()
       
    ' Define constants.
    Const SRC_SHEET_NAME As String = "Open"
    Const SRC_SEARCH_COLUMN As Long = 1
    Const SRC_SEARCH_STRING As String = "Complete"
    Const DST_SHEET_NAME As String = "Billed or Cancelled"
    Const DST_FIRST_COLUMN As String = "B"
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet and ranges.
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim srg As Range:
    With sws.Range("A1").CurrentRegion
        If .Rows.Count = 1 Then
            MsgBox "No invoices found!", vbExclamation
            Exit Sub
        End If
        Set srg = .Resize(.Rows.Count - 1).Offset(1) ' whole range (no headers)
    End With
    Dim slrg As Range: Set slrg = srg.Columns(SRC_SEARCH_COLUMN) ' lookup range
    
    ' Declare additional variables.
    Dim surg As Range, scell As Range, r As Long, CellString As String
    
    ' Combine all matching cells into a unioned range.
    For Each scell In slrg.Cells
        CellString = CStr(scell.Value)
        ' is equal
        If StrComp(CellString, SRC_SEARCH_STRING, vbTextCompare) = 0 Then
        ' contains...
        'If InStr(1, CellString, SRC_SEARCH_STRING, vbTextCompare) > 0 Then
        ' begins with...
        'If InStr(1, CellString, SRC_SEARCH_STRING, vbTextCompare) = 1 Then
            If surg Is Nothing Then
                Set surg = scell
            Else
                Set surg = Union(surg, scell)
            End If
        End If
    Next scell
    
    ' Check if no matching cells.
    If surg Is Nothing Then
        MsgBox "No completed invoices found!", vbExclamation
        Exit Sub
    End If
    
    ' Include all columns in the unioned range.
    Set surg = Intersect(surg.EntireRow, srg)
    
    ' Reference the destination last cell
    ' (assumes that the first cell in each source row is populated).
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    Dim dcell As Range: Set dcell = dws _
        .Cells(dws.Rows.Count, DST_FIRST_COLUMN).End(xlUp).Offset(1)
    
    ' Copy and delete (move) the unioned range.
    surg.Copy Destination:=dcell
    surg.Delete Shift:=xlShiftUp
    
    ' Inform.
    MsgBox "Completed invoices moved.", vbInformation

End Sub

21.05.2024 11:28