Question

我是Excel VBA的新手，我试图让重复的行追加到该行的第一个出现位置。

例如，我们在这里有表格 First Table

我想将数据格式化为此处 Formatted table

逻辑是这样的。每当我们检测到当前和后续行的姓氏和出生日期是相同的，这意味着我们有一个从属，我们需要将相关的数据附加到＆＃34; Main＆＃34;

我已经开始编写代码，但我无法正确检测家属。以下是我所拥有的。请考虑我是一个真正的菜鸟，我正在努力。

Sub formatData()

    Dim sh As Worksheet
    Dim rw As Range
    Dim RowCount As Integer

    'This variable is checked to see if we have a first occurence of a line
    Dim firstOccurence

    'Initialise the variables for that will be used to match the data
    Dim LocationName
    Dim PlanCode
    Dim LastName
    Dim FirstName

    Dim dependantFirstName
    Dim dependantLastName
    Dim dependantBirthdate


    RowCount = 0
    firstOccurence = True

    'Check if the spreadsheet already exist if not create it.
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Benefits Census Formatted" Then
            exists = True
        End If
    Next i

    If Not exists Then
        'Create a new spreadsheet to add the data to
        Set ws = Sheets.Add
        Sheets.Add.Name = "Benefits Census Formatted"
    End If


    'Set the ActiveSheet to the one containing the original data
    Set sh = Sheets("BENEFIT Census")


    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row


    For Each rw In sh.Rows
    'If the data of one cell is empty EXIT THE LOOP
        If sh.Cells(rw.Row, 1).Value = "" Then


    Exit For
        End If

    If rw.Row > 1 Then

       'Afffecting the variables to the next loop so we can compare the values
       nextLocationName = sh.Cells(rw.Row + 1, 1).Value
       nextPlanCode = sh.Cells(rw.Row + 1, 2).Value
       nextLastName = sh.Cells(rw.Row + 1, 3).Value
       nextFirstName = sh.Cells(rw.Row + 1, 4).Value
       nextEmploymentDate = sh.Cells(rw.Row + 1, 5).Value
       nextBirthDate = sh.Cells(rw.Row + 1, 6).Value
       nextDependantFirstName = sh.Cells(rw.Row + 1, 25).Value
       nextDependantLastName = sh.Cells(rw.Row + 1, 26).Value
       nextDependantBirthdate = sh.Cells(rw.Row + 1, 27).Value

       Debug.Print LastName & " - " & FirstName  & " ::: "  & nextLastName & " - " & nextFirstName & " : " & rw.Row & " : " & firstOccurence


       'First time you pass through the loop write the whole lane
        If firstOccurence = True Then

        'Affecting the variables to the current loops values
       LocationName = sh.Cells(rw.Row, 1).Value
       PlanCode = sh.Cells(rw.Row, 2).Value
       LastName = sh.Cells(rw.Row, 3).Value
       FirstName = sh.Cells(rw.Row, 4).Value
       dependantFirstName = sh.Cells(rw.Row, 25).Value
       dependantLastName = sh.Cells(rw.Row, 26).Value
       dependantBirthdate = sh.Cells(rw.Row, 27).Value

       'Write the current line
        sh.Rows(rw.Row).Copy
        'We copy the value into another sheet
        Set ns = Sheets("Benefits Census Formatted")
        LastRow = ns.Cells(ns.Rows.Count, "A").End(xlUp).Row + 1
        ns.Rows(LastRow).PasteSpecial xlPasteValues

        firstOccurence = False


    Else

      'We match the location with the plan code and the last name and first name of the user to find duplicates
       If dependantFirstName <> nextDependantFirstName And PlanCode <> nextPlanCode And LastName <> nextLastName And FirstName <> nextFirstName Then



      'We find a different dependant if the first name or the last name or the birthdate differs
       'If Not (dependantFirstName <> nextDependantFirstName) Or Not (dependantLastName <> nextDependantLastName) Or Not (dependantBirthdate <> nextDependantBirthdate) Then

       'We have a dependant Append it to the line
        'append the user to the currentLine
        'End If

        Else
        'If the dependantFirstName and the nextDependant First name doesn't match then on the next loop  we print the full line
        firstOccurence = True


        End If


        End If

        RowCount = RowCount + 1
        'End of if row > 2
        End If

        Next rw

    End With

End Sub

Answer 1

我会使用一种方法，使用词典来收集和组织数据，然后输出它。根据您的评论和代码判断，您还没有包含很多内容。但是下面的代码将获取您的原始数据，并输出一个接近您显示的表 - 一些结果排序是不同的，但它是标准化的（即每个相关名称都列出了一个关系。

在字典中，我们使用姓氏和出生日期作为＆＃34;键＆＃34;以便将你所说的重复组合起来。

我们定义了两个Class对象

包含名称和关系的从属对象
系列对象，包括名字和姓氏，以及Birthdate以及依赖对象的集合（字典）。

一旦我们将它组织起来，就可以根据需要输出它。

有关类的讨论，您可以进行Internet搜索。我会推荐Chip Pearson的Introduction to Classes

请务必阅读代码中有关重命名类模块的说明，并设置对Microsoft Scripting Runtime的引用

的Class1

Option Explicit
'Rename this module: cDependents
'set reference to Microsoft Scripting Runtime
Private pRelation As String
Private pDepName As String

Public Property Get Relation() As String
    Relation = pRelation
End Property
Public Property Let Relation(Value As String)
    pRelation = Value
End Property

Public Property Get DepName() As String
    DepName = pDepName
End Property
Public Property Let DepName(Value As String)
    pDepName = Value
End Property

的Class2

Option Explicit
'rename this module: cFamily
'set reference to Microsoft Scripting Runtime
Private pFirstName As String
Private pLastName As String
Private pBirthdate As Date
Private pDependents As Dictionary

Public Property Get FirstName() As String
    FirstName = pFirstName
End Property
Public Property Let FirstName(Value As String)
    pFirstName = Value
End Property

Public Property Get LastName() As String
    LastName = pLastName
End Property
Public Property Let LastName(Value As String)
    pLastName = Value
End Property

Public Property Get Birthdate() As Date
    Birthdate = pBirthdate
End Property
Public Property Let Birthdate(Value As Date)
    pBirthdate = Value
End Property

Public Function ADDDependents(Typ, Nme)
    Dim cD As New cDependents
    Dim sKey As String
    With cD
        .DepName = Nme
        .Relation = Typ
        sKey = .Relation & Chr(1) & .DepName
    End With

    If Not pDependents.Exists(sKey) Then
        pDependents.Add Key:=sKey, Item:=cD
    End If
End Function

Public Property Get Dependents() As Dictionary
    Set Dependents = pDependents
End Property


Private Sub Class_Initialize()
    Set pDependents = New Dictionary
End Sub

常规模块

Option Explicit
'set reference to Microsoft Scripting Runtime
Sub Family()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dF As Dictionary, cF As cFamily
    Dim I As Long, J As Long
    Dim sKey As String
    Dim V As Variant, W As Variant

'Set source and results worksheets and results range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'read source data into array
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=5)
End With

'Collect and organize the family and dependent objects
Set dF = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cF = New cFamily
    With cF
        .FirstName = vSrc(I, 1)
        .LastName = vSrc(I, 2)
        .Birthdate = vSrc(I, 3)
        .ADDDependents vSrc(I, 4), vSrc(I, 5)
        sKey = .LastName & Chr(1) & .Birthdate
        If Not dF.Exists(sKey) Then
            dF.Add Key:=sKey, Item:=cF
        Else
            dF(sKey).ADDDependents vSrc(I, 4), vSrc(I, 5)
        End If
    End With
Next I

'Results will have two columns for each relation, including Main
' + three columns at the beginning

'get number of extra columns
    Dim ColCount As Long
    For Each V In dF
        I = dF(V).Dependents.Count
        ColCount = IIf(I > ColCount, I, ColCount)
    Next V
    ColCount = ColCount * 2 + 3


ReDim vRes(0 To dF.Count, 1 To ColCount)
    vRes(0, 1) = "First Name"
    vRes(0, 2) = "Last Name"
    vRes(0, 3) = "Birthdate"
    vRes(0, 4) = "Dependant"
    vRes(0, 5) = "Dependant Name"
    For J = 6 To UBound(vRes, 2) Step 2
        vRes(0, J) = "Relation " & J - 5
        vRes(0, J + 1) = "Dependant Name"
    Next J


I = 0
For Each V In dF
    I = I + 1
    With dF(V)
        vRes(I, 1) = .FirstName
        vRes(I, 2) = .LastName
        vRes(I, 3) = .Birthdate

        J = 2
        For Each W In .Dependents
            J = J + 2
            With .Dependents(W)
                vRes(I, J) = .Relation
                vRes(I, J + 1) = .DepName
            End With
        Next W
    End With
Next V

Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

源数据

结果

Answer 2

这是我为你写的代码。（很高兴看到其他人也这样做了。所以你有一个选择： - ））

Sub TransscribeData()
    ' 25 Mar 2017

    Dim WsS As Worksheet                    ' Source
    Dim WsT As Worksheet                    ' Target
    Dim TargetName As String
    Dim LastRow As Long                     ' in WsS
    Dim Rs As Long                          ' Source: row
    Dim Rt As Long, Ct As Long              ' Target: row / column
    Dim Tmp As String
    Dim Comp As String                      ' compare string

    ' Set Source sheet to the one containing the original data
    Set WsS = Worksheets("BENEFIT Census")
    LastRow = WsS.Cells(WsS.Rows.Count, NbcName).End(xlUp).Row

    Application.ScreenUpdating = False
    TargetName = "Benefits Census Formatted"
    On Error Resume Next
    Set WsT = Worksheets(TargetName)        ' Set the Target sheet
    If Err Then
        ' Create it if it doesn't exist
        Set WsT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        WsT.Name = TargetName
        ' insert the column captions here
    End If
    On Error GoTo 0

    Rt = WsT.Cells(WsS.Rows.Count, NfdName).End(xlUp).Row
    AddMain WsS, WsT, NbcFirstDataRow, Rt    ' Rt is counting in the sub
    For Rs = NbcFirstDataRow To LastRow - 1
        With WsS.Rows(Rs)
            Tmp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
        End With
        With WsS.Rows(Rs + 1)
            Comp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
        End With
        If StrComp(Tmp, Comp, vbTextCompare) Then
            AddMain WsS, WsT, Rs + 1, Rt
        Else
            Ct = WsT.Cells(Rt, WsT.Columns.Count).End(xlToLeft).Column
            If Ct > NfdMain Then Ct = Ct + 1
            With WsS.Rows(Rs + 1)
                WsT.Cells(Rt, Ct + NfdRelate).Value = .Cells(NbcRelate).Value
                WsT.Cells(Rt, Ct + NfdDepName).Value = .Cells(NbcDepName).Value
            End With
        End If
    Next Rs
    Application.ScreenUpdating = True
End Sub

上面的代码调用一个Sub例程，你必须在相同的代码模块中添加它，顺便说一下，它应该是一个普通的代码模块（默认情况下＆＃34; Module1＆＃34;但你可以将它重命名为任何代码模块）

Private Sub AddMain(WsS As Worksheet, WsT As Worksheet, _
                    Rs As Long, Rt As Long)
    ' 25 Mar 2017

    Rt = Rt + 1
    With WsS.Rows(Rs)
        WsT.Cells(Rt, NfdFname).Value = .Cells(NbcFname).Value
        WsT.Cells(Rt, NfdName).Value = .Cells(NbcName).Value
        WsT.Cells(Rt, NfdDob).Value = .Cells(NbcDob).Value
        WsT.Cells(Rt, NfdMain).Value = "Main"
    End With
End Sub

注意我插入了＆＃34; Main＆＃34;作为硬文。您还可以在“源”表中复制相应调用的内容。此过程仅写入第一个条目。家属是由另一个代码编写的。

整个代码由两个＆＃34; enums＆＃34;，枚举控制，每个工作表一个。枚举是为数字指定名称的最快方法。请在两个程序之前将这两个枚举粘贴到代码表的顶部。

Private Enum Nbc                        ' worksheet Benefit Census
    NbcFirstDataRow = 2                 ' Adjust as required
    NbcFname = 1                        ' columns:
    NbcName
    NbcDob
    NbcRelate
    NbcDepName
End Enum

Private Enum Nfd                        ' worksheet Formatted Data
    NfdFirstDataRow = 2                 ' Adjust as required
    NfdName = 1                         ' columns:
    NfdFname
    NfdDob
    NfdMain
    NfdRelate = 0                       ' Offset from NfdMain
    NfdDepName
End Enum

请注意，枚举规则是您可以为它们分配任何整数。如果您没有指定任何数字，则该值将比前一个值高一个。因此，NfdMain = 4，后跟NfdRelate，其赋值为0，后跟NfdDepName，其值为0 + 1 = 1.

这些枚举中的数字是列（和行）。您可以通过调整这些数字来控制整个输出。例如，＆＃34; Main＆＃34;写入NfdMain列（= 4 = D）。将值更改为5和＆＃34; Main＆＃34;将出现在第5列= E中。无需在代码中进行搜索。考虑一下这是一个控制面板。

在格式化输出中，我引入了一个与你的略有不同的逻辑。如果你不喜欢它，你可以通过修改枚举轻松地改变它。我的逻辑将姓氏作为第一列中的主要标准（从原始数据切换）。在D栏中，我写了＃34; Main＆＃34;。但是当有一个从属关系时，我会在D列中写下这种关系。因此，只有没有任何家属的条目才会有＆＃34; Main＆＃34;在那一栏。对于您的第一个示例，格式化的行将显示Rasmond / Shawn / 01-01-1990 / Spouse / Jessica，Child 1 / Vanessa。

如果您希望保留＆＃34;主要和地点＆＃34;配偶＆＃34;在下一列中，只需设置枚举NfdRelate = 1.使用＆＃34;控制面板＆＃34;它很简单。

Excel宏将重复项附加到第一行

2 个答案:

的Class1

的Class2

常规模块

源数据

结果