Объединить ячейки и удалить повторяющиеся данные

Question

У меня есть список компаний, и у каждого есть объем работы, адрес и номер телефона. Некоторые из компаний имеют множество областей работы. Это выглядит примерно так:

Я хочу, чтобы избавиться от второй копии вещи, как адрес (и в моем случае, номера телефонов и такими) при копировании уникальных данных во второй строке и помещая его в первую строку, а затем избавляясь от второй линии.

У меня очень мало опыта в кодировании. Я посмотрел, как это делается шаг за шагом, но что-то не так в коде или синтаксисе:

1. Я нашел код для перехода по столбцу для пробела.
2. Я посмотрел, как скопировать ячейку справа от активной пустой ячейки.
3. Я нашел код для объединения информации в ячейку выше и один справа от активной ячейки.
4. Я нашел код, который удаляет строку с активной ячейкой.
5. Я хочу, чтобы он зацикливался до тех пор, пока не будет больше пустых company ячеек.

Так вот как я положил его вместе:

Public Sub SelectFirstBlankCell() 
    Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer 
    Dim currentRowValue As String 

    Do 
    sourceCol = 6 'column F has a value of 6 
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row 

    'for every row, find the first blank cell and select it 
    For currentRow = 1 To rowCount 
     currentRowValue = Cells(currentRow, sourceCol).Value 
     If IsEmpty(currentRowValue) Or currentRowValue = "" Then 
     Cells(currentRow, sourceCol).Select 
     End If 
    Next 
    Loop Until A647 
End Sub 

.

Sub mergeIt() 
    Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(1, 1)).Merge 
    ActiveCell.Select 
End Sub 

.

Sub DeleteRow() 
    RowNo = ActiveCell.Row 
    If RowNo < 7 Then Exit Sub 
    Range("A" & ActiveCell.Row).EntireRow.Delete 

    Sheets("Summary").Select 
    Range("A4:O4").Select 
    Selection.Copy 
    LastRow = Range("A65536").End(xlUp).Offset(1, 0).Row 
End Sub 

Answer 1

Пожалуйста, никогда не отправляйте код как изображение, так как тот, кто хочет попробовать, должен набрать его. Вы можете отредактировать свой вопрос и при необходимости добавить новый раздел, включая измененный код.

Моя копия кода (плюс номера строк) является:

1 Public Sub SelectFirstBlankCell() 
2 Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer 
3 Dim currentRowValue As String 

4 sourceCol = 1 'column F has a value of 6 
5 rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row 

6 'for every row, find the first blank cell and select it 
7 For currentRow = 1 To rowCount 
8  currentRowValue = Cells(currentRow, sourceCol).Value 
9  If IsEmpty(currentRowValue) Or currentRowValue = "" Then 
10  Cells(currentRow, sourceCol).Select 
11  End If 
12  Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 1)).Merge 
13  ActiveCell.Select 
14  If IsEmpty(currentRowValue) Or currentRowValue = "" Then 
15  Cells(Range("sourceCol:21")).Delete 
16  End If 
17  Next 

18 End Sub 

Я уверен, что все мы начали выбирать клетки и доступ к ActiveCell, поскольку записи макросов делает это. Однако выбор ячеек медленный, и очень легко потерять информацию о том, что выбрано. Я считаю, что это ваша главная проблема.

Задача 1 Конечное значение для For-Loop фиксировано в начале; Любые попытки уменьшить rowCount, когда вы удаляете что-то, не будут влиять на For-Loop.

Проблема 2 Я подозреваю, что вы имеете в виду диапазон в строке 15, который должен быть sourceCol & ":" & currentRow.

Задача 3 В строке 10 вы выбираете ячейку, если она пуста. В строке 12 вы объединяете активную ячейку, независимо от того, вы ее только что выбрали. Это означает, что ваш код пытается слить для каждой строки.

Задача 4 Столбец 1 - это столбец, который может быть пустым. Предположим, что строка 1000 является последней строкой с именем поставщика, но строка 1005 является последней строкой с продуктом. Ваш код не будет обрабатывать строки с 1001 по 1005.

Задача 5 Функция IsEmpty() возвращает только разумные значения для вариантов. Вариант - это либо ячейка, либо переменная, которая может содержать разные типы значений.

Я еще не пробовал ваш код, поэтому может быть больше ошибок. Успокойся. Насколько я знаю, проблема 1 не документирована. Мне пришлось открыть эту «функцию» для себя, пытаясь использовать код, похожий на ваш. Спецификация функции IsEmpty() устанавливает свои ограничения, но, если вы не полностью понимаете варианты, значение не очевидно. Другие проблемы - легкие ошибки, и только практика уменьшит их частоту.

Ниже мое решение проблемы. Это не то, как я бы закодировал его для себя, но я думаю, что я представил достаточно новых концепций для одного решения.

Я не говорю о синтаксисе операторов VBA, которые я использую, поскольку обычно легко найти заявление, как только вы его знаете. Спросите, если необходимо, но, пожалуйста, попробуйте понять код, прежде чем спрашивать.

Мне не нравится удаление на месте; он медленный, и если ваш код неисправен, вам нужно загрузить предыдущую версию рабочего листа и начать заново. У меня есть источник (Src) и рабочий лист назначения (Dest).

Я использую константы для значений, которые могут меняться, но не во время одного запуска вашего макроса.

Вы принимаете адрес и другие данные для поставки Яна по строкам 2 и 3. Я параноик и никогда не делаю таких предположений. Если мой код будет отбрасывать важную информацию, если строки 2 и 3 не совпадают, я проверяю их соответствие. Я также позволяю строки, как это потому, что я столкнулся с ними:

John's supply Cookies   555 Main Street    CA 
       Cakes        Littleville CA 

Это станет:

John's supply Cookies & Cakes 555 Main Street Littleville CA 

Некоторые из комментариев объясняет свой выбор заявления VBA, но большинство этого не делает. Когда вам нужно обновить макрос, который вы написали 12 месяцев назад для новых требований, несколько минут, которые вы потратили на добавление комментариев, могут сэкономить вам время на поиск кода.

Возможно, вам не нравится моя система именования переменных. Fine; развивать свой собственный. Когда вы вернетесь к этому макросу через 12 месяцев, немедленное понимание переменных сэкономит больше времени.

Option Explicit 

    Const WkshtSrcName As String = "Sheet1" ' \ Replace "Sheet1" and "Sheet2" 
    Const WkshtDestName As String = "Sheet2" '/with the names of your worksheets 
    Const ColSupplier As String = "A"   ' \ In Cells(R, C), C can be a 
    Const ColProduct As String = "B"   '/number or a column identifier 
    Const RowDataFirst As Long = 1 
Sub MergeRowsForSameSupplier() 

    Dim ColCrnt As Long   ' \ Columns in source and destination are the 
    Dim ColMax As Long   '/same so single variables are adequate. 
    Dim RowDestCrnt As Long  ' \ Rows in source and destination 
    Dim RowSrcCrnt As Long  ' | worksheets are different 
    Dim RowSrcMax As Long  '/so need separate variables. 

    Dim ProductCrnt As String 
    Dim Join As String 
    Dim SupplierCrnt As String 
    Dim WkshtSrc As Worksheet 
    Dim WkshtDest As Worksheet 

    Set WkshtSrc = Worksheets(WkshtSrcName) 
    Set WkshtDest = Worksheets(WkshtDestName) 

    With WkshtSrc 
    ' I consider this to be the easiest technique of identifying the last used 
    ' row and column in a worksheet. Note: the used range includes trailing 
    ' rows and columns that are formatted but otherwise unused or were used but 
    ' aren't now so other techniques can better match what the user or the 
    ' programmer usually mean by "used". 
    ColMax = .UsedRange.Columns.Count 
    RowSrcMax = .UsedRange.Rows.Count 
    End With 

    With WkshtDest 
    .Cells.EntireRow.Delete   ' Delete any existing contents 
    End With 

    RowDestCrnt = RowDataFirst 

    For RowSrcCrnt = RowDataFirst To RowSrcMax 
    With WkshtSrc 
     SupplierCrnt = .Cells(RowSrcCrnt, ColSupplier).Value 
     ProductCrnt = .Cells(RowSrcCrnt, ColProduct).Value 
    End With 
    If SupplierCrnt <> "" Then 
     ' This is the first or only row for a supplier. 
     ' Copy it to Destination worksheet. 
     With WkshtSrc 
     .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax)).Copy _ 
           Destination:=WkshtDest.Cells(RowDestCrnt, 1) 
     End With 
     RowDestCrnt = RowDestCrnt + 1 
    ElseIf ProductCrnt = "" Then 
     ' Both Supplier and Product cells are empty. 
     With WkshtSrc 
     If .Cells(RowSrcCrnt, Columns.Count).End(xlToLeft).Column = 1 And _ 
      .Cells(RowSrcCrnt, 1).Value = "" And _ 
      .Cells(RowSrcCrnt, Columns.Count).Value = "" Then 
      ' If you do not understand why I have so many tests, 
      ' experiment with Ctrl+Left 
      ' Row empty so ignore it 
     Else 
      ' Don't know what to do with this error so give up 
      Call MsgBox("Cells " & ColSupplier & RowSrcCrnt & " and " & _ 
         ColProduct & RowSrcCrnt & " of worksheet " & _ 
         WkshtSrcName & _ 
         " are blank but the entire row is not blank", _ 
         vbOKOnly + vbCritical, "Merge rows for same supplier") 
      Exit Sub 
     End If 
     End With 
    Else 
     ' Supplier cell is empty. Product cell is not. 
     ' Row RowDestCrnt-1 of the Destination worksheet contains the first row 
     ' for this supplier or the result of merging previous rows for this 
     ' supplier. 
     If WkshtSrc.Cells(RowSrcCrnt + 1, ColSupplier).Value = "" And _ 
     WkshtSrc.Cells(RowSrcCrnt + 1, ColProduct).Value <> "" Then 
     ' The next row is for the same supplier but is not a blank row 
     Join = "," 
     Else 
     ' This is last row for this supplier 
     Join = " &" 
     End If 
     ' Add to list of products 
     With WkshtDest 
     .Cells(RowDestCrnt - 1, ColProduct).Value = _ 
      .Cells(RowDestCrnt - 1, ColProduct).Value & Join & " " & _ 
      ProductCrnt 
     End With 
     For ColCrnt = 1 To ColMax 
     If ColCrnt = Cells(1, ColSupplier).Column Or _ 
      ColCrnt = Cells(1, ColProduct).Column Then 
      ' You may think (and you may be right) that the supplier and product 
      ' will always be in the first two columns. But have seen the 
      ' weirdest arrangements and make no assumptions 
      ' Ignore this column 
     Else 
      If WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = "" Then 
      ' The most likely arrangement: the subsequent row has no 
      ' value in this column. Nothing to do. 
      ElseIf WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value = "" Then 
      ' This source row has a value in this column but [the] previous 
      ' row[s] did not. 
      ' Note: I use the copy statement because it copies formatting as 
      ' well as the value which may be useful. 
      WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Copy _ 
          Destination:=WkshtDest.Cells(RowDestCrnt - 1, ColCrnt) 
      ElseIf WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = _ 
       WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value Then 
      ' Values match. Nothing to do. 
      Else 
      ' Values do not match. 
      ' Don't know what to do with this error so give up. 
      Call MsgBox("The value in cell " & ColNumToCode(ColCrnt) & _ 
         RowSrcCrnt & " of worksheet " & WkshtSrcName & _ 
         " does not match a value in an earlier row " & _ 
         "for the same supplier", _ 
         vbOKOnly + vbCritical, "Merge rows for same supplier") 
      Exit Sub 
      End If 
     End If 
     Next 
    End If 
    Next 

    With WkshtDest 
    .Cells.Columns.AutoFit 
    End With 


End Sub 
Function ColNumToCode(ByVal ColNum As Long) As String 

    ' Convert a column identifier (A, AA, etc.) to its number 

    Dim Code As String 
    Dim PartNum As Long 

    ' Last updated 3 Feb 12. Adapted to handle three character codes. 
    If ColNum = 0 Then 
    ColNumToCode = "0" 
    Else 
    Code = "" 
    Do While ColNum > 0 
     PartNum = (ColNum - 1) Mod 26 
     Code = Chr(65 + PartNum) & Code 
     ColNum = (ColNum - PartNum - 1) \ 26 
    Loop 
    End If 

    ColNumToCode = Code 

End Function