Question

嗨我在excel中使用vba进行编码时遇到了一些问题。我有一个邮件列表，每个人都有一排，但有很多人和另一个人在同一个家庭。两者都具有相同的地址并具有匹配的家庭ID。我需要将具有相同家庭ID和地址的人名组合在一起，这样MS词就可以为每个家庭制作邮寄标签。

代码需要查找具有相同家庭ID，称呼，征求说明，街道1，街道2，街道3，城市，州，邮政编码的行。并将顶部和底部行中的文本与＆＃34;＆amp;＆＃34;邮件名称，明矾Y / N，捐助者Y / N，可征集。结果是＆amp;之前的顶行信息。然后是最后一排。所有数据已经排序，因此重复的家庭ID在一起。我编码很多，并没有使用很多命名约定。我从一些论坛拼凑了这个。我得到了关键部分的错误。示例附加了excel图片，希望它们能够查看。欢迎任何帮助。谢谢:)

Sub merge_A_to_D_data()
Dim rw As Long, lr As Long, str As String, dbl As Double

Application.ScreenUpdating = False
With ActiveSheet.Cells(1, 1).CurrentRegion
    .Cells.Sort Key1:=.Columns(2), Order1:=xlAscending, _
                Key2:=.Columns(4), Order2:=xlAscending, _
                Key3:=.Columns(5), Order3:=xlAscending, _
                Key4:=.Columns(6), Order4:=xlAscending, _
                Key5:=.Columns(7), Order5:=xlAscending, _
                Key6:=.Columns(8), Order6:=xlAscending, _
                Key7:=.Columns(9), Order7:=xlAscending, _
                Key8:=.Columns(10), Order8:=xlAscending, _
                Key9:=.Columns(11), Order9:=xlAscending, _
                Key10:=.Columns(12), Order10:=xlAscending, _
                Key11:=.Columns(13), Order11:=xlAscending, _
                Key12:=.Columns(14), Order12:=xlAscending, _
                Key13:=.Columns(15), Order13:=xlAscending, _
                Orientation:=xlTopToBottom, Header:=xlYes
    lr = .Rows.Count
    For rw = .Rows.Count To 2 Step -1
        If .Cells(rw, 2).Value2 <> .Cells(rw - 1, 2).Value2 And _
            .Cells(rw, 4).Value2 <> .Cells(rw - 1, 4).Value2 And _
            .Cells(rw, 5).Value2 <> .Cells(rw - 1, 5).Value2 And _
            .Cells(rw, 6).Value2 <> .Cells(rw - 1, 6).Value2 And _
            .Cells(rw, 7).Value2 <> .Cells(rw - 1, 7).Value2 And _
            .Cells(rw, 8).Value2 <> .Cells(rw - 1, 8).Value2 And _
            .Cells(rw, 9).Value2 <> .Cells(rw - 1, 9).Value2 And _
            .Cells(rw, 10).Value2 <> .Cells(rw - 1, 10).Value2 And _
            .Cells(rw, 11).Value2 <> .Cells(rw - 1, 11).Value2 And _
            .Cells(rw, 12).Value2 <> .Cells(rw - 1, 12).Value2 And _
            .Cells(rw, 13).Value2 <> .Cells(rw - 1, 13).Value2 And _
            .Cells(rw, 14).Value2 <> .Cells(rw - 1, 14).Value2 And _
            .Cells(rw, 15).Value2 <> .Cells(rw - 1, 15).Value2 And rw < lr Then
             .Cells(rw, 3) = Join(Application.Transpose(.Range(.Cells(rw, 3), .Cells(lr, 3))), Chr(59))
             .Cells(rw + 1, 1).Resize(lr - rw, 1).EntireRow.Delete
             lr = rw - 1
        End If
    Next rw
End With
Application.ScreenUpdating = True
End Sub

before code run, pic

after code run, pic

Answer 1

这取决于您发布的数据图片。如果数据位于不同的列中，则需要将这些更改应用于代码。这会对您的数据进行排序，并在名为＆＃34;标签＆＃34;的新工作表中移动/组合行。排序是针对整个工作表的，因为您没有解释使用CurrentRegion。

Sub Concatenate_data()
Set WB = ActiveWorkbook
Set ws = WB.ActiveSheet
ws.Sort.SortFields.Clear
With ws.Sort
.SortFields.Add Key:=ws.Cells(1, 1)
.SortFields.Add Key:=ws.Cells(1, 2)
.SortFields.Add Key:=ws.Cells(1, 4)
.SortFields.Add Key:=ws.Cells(1, 5)
.SortFields.Add Key:=ws.Cells(1, 6)
.SortFields.Add Key:=ws.Cells(1, 7)
.SortFields.Add Key:=ws.Cells(1, 8)
.SortFields.Add Key:=ws.Cells(1, 9)
.SortFields.Add Key:=ws.Cells(1, 10)
.SortFields.Add Key:=ws.Cells(1, 11)
.SortFields.Add Key:=ws.Cells(1, 12)
.SortFields.Add Key:=ws.Cells(1, 13)
.SortFields.Add Key:=ws.Cells(1, 14)
.SortFields.Add Key:=ws.Cells(1, 15)

 .Header = xlYes
 .SetRange Range("A1:O" & ws.Rows.Count) 'this is a static range
 .Apply
End With

WB.Sheets.Add(After:=WB.Sheets(WB.Sheets.Count)).Name = "Labels" 'creates new worksheet
        Worksheets("Labels").Columns(1).NumberFormat = "@" 'formats household ID to be text so you don't lose leading zeros
        Worksheets("Labels").Rows(1).Value = ws.Rows(1).Value ' header row
  'lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
               rwlabel = 2
    For rw = ws.Range("A" & ws.Rows.Count).End(xlUp).Row To 2 Step -1
        If ws.Cells(rw, 1).Value = ws.Cells(rw - 1, 1).Value Then 'only checks for duplicate household ID.  You can add more conditions as you need
           Worksheets("Labels").Rows(rwlabel).Value = ws.Rows(rw).Value ' copy entire row

            Worksheets("Labels").Cells(rwlabel, 4).Value = ws.Cells(rw, 4) & Chr(38) & ws.Cells(rw - 1, 4)
            Worksheets("Labels").Cells(rwlabel, 5).Value = ws.Cells(rw, 5) & Chr(38) & ws.Cells(rw - 1, 5)
            Worksheets("Labels").Cells(rwlabel, 6).Value = ws.Cells(rw, 5) & Chr(38) & ws.Cells(rw - 1, 6)
            rw = rw - 1 'increment  passeed the duplicate line on you data (activeworksheet)
        Else
          Worksheets("Labels").Rows(rwlabel).Value = ws.Rows(rw).Value  'copies entire row that has no duplicate household ID

        End If
                     rwlabel = rwlabel + 1
    Next rw
End Sub

根据其他列中的匹配数据连接不同行中的数据，同时保留所有数据

1 个答案: