Question

我有一张工作表，每行都有策略。我想做的是搜索与同一个人相关联的政策，并将其全部放在同一行。因此，如果有针对约翰·史密斯（John Smith）的两项政策，那么它们将在排序后排在同一行。

包含的代码表明，我首先要弄清楚有多少行。我运行一个循环，从带有条目（第2行）的第一行到工作表的末尾。对于这些行中的每一行，我都存储该人的名字和姓氏。然后，我在嵌套的for循环中搜索该行下面的行。如果发现匹配，则将其复制并将其粘贴到与名称的第一个实例相同的行中，并将其粘贴到第一行的末尾。然后，它删除已移动的行，并将j减1，以说明已删除行的事实。

它挂在if语句内部的m赋值上，该赋值用于确定将行粘贴到其中的时间。然后似乎跟后面的复制和粘贴命令有问题。（可能是因为在语句中使用了变量？）

感谢您的帮助！

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

如何在VBA中复制行并将该行粘贴到另一行的末尾？

1 个答案: