Объединять данные в разных строках на основе совпадающих данных в других столбцах, сохраняя все данные - PullRequest
0 голосов
/ 24 апреля 2018

привет, у меня возникли некоторые проблемы с кодированием VBA в Excel. У меня есть список рассылки, в котором есть строки для каждого человека, однако есть много людей, которые находятся в тех же домохозяйствах, что и другой человек. у обоих одинаковые адреса и совпадающий идентификатор домохозяйства. Мне нужно объединить имена людей с одним и тем же идентификатором и адресом домохозяйства, чтобы MS Word мог сделать почтовые ярлыки для каждого дома.

Код должен найти строки с одинаковым идентификатором домохозяйства, Приветствие, Описание запроса, Улица 1, Улица 2, Улица 3, Город, Штат, Почтовый индекс. и объедините текст в верхней и нижней строке с символом «&» для имени почты, квасцов Y / N, доноров Y / N, Solicitable. Где результат - информация о верхних строках до & и нижняя строка после. Все данные уже отсортированы, поэтому дубликаты идентификаторов домохозяйств находятся вместе. Я не очень много кодирую и не пользуюсь многими соглашениями об именах. Я собрал это на некоторых форумах. Я получаю сообщение об ошибке с ключевым разделом. Примеры изображений 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

до запуска кода, рис.

после запуска кода, рис.

1 Ответ

0 голосов
/ 25 апреля 2018

Это основано на ваших данных фотографии вы разместили. Если ваши данные находятся в разных столбцах, вам нужно будет применить эти изменения к коду. Это сортирует ваши данные и перемещает / объединяет строки в новом листе под названием «Метки». Сортировка предназначена для всего листа, так как вы не использовали объяснение 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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...