Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос для удаления дублей, с переносом данных двух стоблцов
 
Необходим макрос, который удаляет дубликаты строки, в которых отличается только 2 столбца (H и I). При этом текст в этих столбцах должен скопироваться из удаляемых строк и через ", " вставиться в оригинальную строку. Пожалуйста, посмотрите прикрепленный пример
 
Раздел форума называется "Вопросы по MS Excel". В чём Ваш вопрос?
 
Цитата
Необходим макрос, который удаляет дубликаты строки, в которых отличается только 2 столбца (H и I)
Используйте два словаря: один для столбца H-Технология ADSL, другой - для I-Технология GPON.
Для ключа используйте конкатенацию первых семи ячеек (столбцы A-G) и "|"
 
Цитата
Kuzmich написал:
Используйте два словаря: один для столбца H-Технология ADSL, другой - для I-Технология GPON.Для ключа используйте конкатенацию первых семи ячеек (столбцы A-G) и "|"
К сожалению, я вообще не знаю как писать макросы :(
 
решил попытаться в один словарь всё запихнуть, помещая в Item массив...Вроде работает как надо, но чего-то раньше такого не делал, не уверен, что правильно нашаманил..)
Код
Sub cnc()
Dim dic, mass()
ReDim mass(1 To 2)
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lr
    For j = 1 To 7
        k = k & Cells(i, j).Value & "|"
    Next
    k = Mid(k, 1, Len(k) - 1)
    If dic.exists(k) Then
        mass() = dic.Item(k)
        If mass(1) = "" Then
            mass(1) = Cells(i, 8).Value
        Else
            If Cells(i, 8).Value <> "" Then mass(1) = mass(1) & "," & Cells(i, 8).Value
        End If
        If mass(2) = "" Then
        mass(2) = Cells(i, 9).Value
        Else
            If Cells(i, 9) <> "" Then mass(2) = mass(2) & "," & Cells(i, 9).Value
        End If
        dic.Item(k) = mass()
    Else
        mass(1) = Cells(i, 8).Value
        mass(2) = Cells(i, 9).Value
        dic.Add k, mass()
    End If
k = ""
Next
lr = lr + 2
For Each k In dic.keys
    s = Split(k, "|")
        For j = LBound(s) To UBound(s)
            Cells(lr, j + 1).Value = s(j)
        Next
    Cells(lr, 8).Value = dic.Item(k)(1)
    Cells(lr, 9).Value = dic.Item(k)(2)
    lr = lr + 1
Next
End Sub

с выгрузкой неожидал, что запись
Код
    Cells(lr, 8).Value = dic.Item(k)(1)
    Cells(lr, 9).Value = dic.Item(k)(2)
vba правильно поймет, но результат получился какой и требовался...
 
Разъедините ячейку со словом СТАЛО и перенесите его в Е14.
Код
Sub iDelDubl()
Dim Dic_ADSL As Object
Dim Dic_GPON As Object
Dim i As Long
Dim j As Integer
Dim n As Integer
Dim iLastRow As Long
Dim temp As String
Dim arr
   Set Dic_ADSL = CreateObject("scripting.dictionary"): Dic_ADSL.comparemode = 1
   Set Dic_GPON = CreateObject("scripting.dictionary"): Dic_GPON.comparemode = 1
     iLastRow = [A2].End(xlDown).Row
  For i = 3 To iLastRow
     temp = Cells(i, 1) & "|" & Cells(i, 2) & "|" & Cells(i, 3) & "|" & Cells(i, 4) _
          & "|" & Cells(i, 5) & "|" & Cells(i, 6) & "|" & Cells(i, 7)
        Dic_ADSL.Item(temp) = Dic_ADSL.Item(temp) & Cells(i, 8) & " "
        Dic_GPON.Item(temp) = Dic_GPON.Item(temp) & Cells(i, 9) & " "
  Next
    n = 0
   For Each ikey In Dic_ADSL.keys
     Cells(16 + n, 1).Resize(, 7) = Split(ikey, "|")
     n = n + 1
   Next ikey
    Range("H16").Resize(Dic_ADSL.Count) = Application.Trim(Application.Transpose(Dic_ADSL.Items))
    Range("I16").Resize(Dic_GPON.Count) = Application.Trim(Application.Transpose(Dic_GPON.Items))
End Sub
 
Kuzmich, не могли бы вы поправить макрос, чтобы он работал на обычном файле (без слов БЫЛО, СТЛО). Прикрепил такой.
 
Макрос выгружает строки без дублей. начиная с 14 строки, разделителем в столбцах H и I является пробел.
Код
Sub iDelDubl()
Dim Dic_ADSL As Object
Dim Dic_GPON As Object
Dim i As Long
Dim n As Integer
Dim iLastRow As Long
Dim temp As String
Dim iKey
   Set Dic_ADSL = CreateObject("scripting.dictionary"): Dic_ADSL.comparemode = 1
   Set Dic_GPON = CreateObject("scripting.dictionary"): Dic_GPON.comparemode = 1
     iLastRow = [A1].End(xlDown).Row
  For i = 2 To iLastRow
     temp = Cells(i, 1) & "|" & Cells(i, 2) & "|" & Cells(i, 3) & "|" & Cells(i, 4) _
          & "|" & Cells(i, 5) & "|" & Cells(i, 6) & "|" & Cells(i, 7)
        Dic_ADSL.Item(temp) = Dic_ADSL.Item(temp) & Cells(i, 8) & " "
        Dic_GPON.Item(temp) = Dic_GPON.Item(temp) & Cells(i, 9) & " "
  Next
    n = 0
   For Each iKey In Dic_ADSL.keys
     Cells(14 + n, 1).Resize(, 7) = Split(iKey, "|")
     n = n + 1
   Next iKey
    Range("H14").Resize(Dic_ADSL.Count) = Application.Trim(Application.Transpose(Dic_ADSL.Items))
    Range("I14").Resize(Dic_GPON.Count) = Application.Trim(Application.Transpose(Dic_GPON.Items))
End Sub
Попробуйте также вариант от yozhik
Страницы: 1
Читают тему (гостей: 1)
Наверх