Как вы копируете строки в VBA и вставляете строку в конец другой строки?

Question

У меня есть лист с политиками, размещенными в каждой строке. Я хотел бы найти политики, связанные с одним и тем же человеком, и поместить их в один ряд. Таким образом, если бы у Джона Смита было две политики, они были бы в одном ряду после сортировки.

Включенный код показывает, что я сначала выясняю, сколько строк. Я запускаю цикл, начиная с первой строки с записями (строка 2) до конца листа. Для каждой из этих строк я сохраняю имя и фамилию человека. Затем я ищу строки под этой строкой внутри вложенного цикла. Если он находит, что есть совпадение, он копирует и вставляет строку в ту же строку, что и первый экземпляр имени в конце первой строки. Затем он удаляет перемещенную строку и уменьшает j на 1, чтобы учесть тот факт, что строка была удалена.

Он зависает от присваивания m внутри оператора if, предназначенного для определения длины вставляемой строки. Затем возникает проблема с командой копирования и вставки, которая следует ниже. (Возможно, из-за использования переменных в выражениях?)

Любая помощь приветствуется!

Sub Sort()

'''''''''''''''''''''''''''''''''''''''''''''''''''
' This program sorts data by putting all of an    '
' insureds policies on the same row.              '
'''''''''''''''''''''''''''''''''''''''''''''''''''

Dim wb As Workbook                       'used for the active workbook
Dim wsSrc As Worksheet                  'name of the source sheet
Set wb = ActiveWorkbook                 'sets the active workbook
Set wsSrc = wb.Sheets("Policies")  'will be sheet being sorted

Dim i, j As Integer          'will be used as an index

'used to store the name of current insured for comparison
Dim firstname, lastname As String    

Dim n, m As Integer         'both are to be used for sizing of a sheet

' Determines how long the sheet is (length and width)
n = wsSrc.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
m = wsSrc.Range("2:2").Find(what:="*", searchdirection:=xlPrevious).Column


' Loop runs through the sheet row by row to find those 
' with the same name and then places these on the same row
For i = 2 To n

    firstname = wsSrc.Range("B" & i).Value   'assigns the current first name
    lastname = wsSrc.Range("A" & i).Value   'assigns the last name

    'searches the rows underneath the current row for duplicate names
    For j = i + 1 To n

        'finds duplicates
        If wsSrc.Range("B" & j).Value = firstname And wsSrc.Range("A" & j).Value = lastname Then
            m = wsSrc.Range("i:i").Find(what:="*", searchdirection:=xlPrevious).Column
            'if true places the row at the end of the row that is the current insured.
            wsSrc.Range("A" & j).EntireRow.Copy wsDest.Cells(i, m + 1)
            'deletes the row that has been moved
            wsSrc.Rows(j).Delete
            'if true then a row is deleted and everything beneath it shifts up
            'to accomodate this we move j back by one and we need to reevaluate
            'length of the sheet
            n = wsSrc.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
            j = j - 1


        End If

    Next

Next

End Sub

Answer 1

Вы не можете скопировать всю строку и вставить ее куда угодно, но в ColA - места недостаточно (и Excel не волнует, если большая часть скопированной строки пуста ...)

Вы можетеизбегать вложенного цикла и сбрасывать n и m, работая снизу вверх, используя что-то вроде этого:

Sub Sort()

    Dim wb As Workbook
    Dim wsSrc As Worksheet
    Dim i As Long         'will be used as an index
    Dim n, m As Long, mtch

    Set wb = ActiveWorkbook
    Set wsSrc = wb.Sheets("Policies")

    ' Determines how long the sheet is (length and width)
    n = wsSrc.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    m = wsSrc.Range("2:2").Find(what:="*", searchdirection:=xlPrevious).Column

    For i = n To 2 Step -1
        'Find the first matching row based on First & Last names
        'https://www.deskbright.com/excel/index-match-multiple-criteria/
        mtch = wsSrc.Evaluate("MATCH(A" & i & "&B" & i & ",A:A&B:B,0)")

        If mtch < i Then
            'matched row is above this one, so copy this row up and delete
            wsSrc.Cells(i, 1).Resize(1, m).Copy _
                wsSrc.Cells(mtch, Columns.Count).End(xlToLeft).Offset(0, 1)
            wsSrc.Rows(i).Delete
        End If

    Next i

End Sub