Макрос Excel: разделите значения ячеек по нескольким столбцам на несколько строк и сохраните другие данные

Question

Воспроизводимый пример:

ColA    ColB        ColC        ColD                              ColE
Reg1    Station1    1|2|3|4|5   1.1|1.2|1.3|2.1|3.1|4.1|4.2|5.1   1.1.1|1.1.2

Желаемый результат:

ColA    ColB    ColC    ColD    ColE
Reg1    Station1    1   1.1     1.1.1
Reg1    Station1    1   1.1     1.1.2
Reg1    Station1    1   1.2 
Reg1    Station1    1   1.3 
Reg1    Station1    2   2.1 
Reg1    Station1    3   3.1 
Reg1    Station1    4   4.1 
Reg1    Station1    4   4.2 
Reg1    Station1    5   5.1 

Я пробовал это решение: Разделить значения ячеек на несколько строк и сохранить другие данные

Но это не относится к разделению строк по нескольким значениям столбцов.

Итак, я попробовал это:

Sub splitByColB()
    Dim r As Range, i As Long, ar
    Set r = Worksheets("Sheet1").Range("C999999:E999999").End(xlUp)
    Do While r.Row > 1
        ar = Split(r.Value, "|")
        If UBound(ar) >= 0 Then r.Value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).Value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
End Sub

Были разделены только значения в столбце C, и мне нужен вывод, подобный приведенному выше.

Answer 1

Сначала несколько комментариев к вашему коду и вопрос.

Никогда не пытайтесь выполнить преобразование рабочего листа, подобное этому, на месте. Если ваш код не работает, вы уничтожили исходный рабочий лист. Если у вас есть резервная копия, вы можете восстановить исходный рабочий лист, но это неприятно. Намного проще построить новый формат на новом листе.

Вы не предоставляете достаточно информации, чтобы полностью понять ваше требование:

1. Вы предоставляете только одну строку примера, но ваш код, похоже, обрабатывает несколько строк. Сколько строк нужно обработать? Если есть сотни тысяч строк, эффективность будет важнее, чем если бы их было всего несколько сотен.
2. Есть ли у вас один рабочий лист, который нужно преобразовать, или вы регулярно получаете данные в этом сжатом формате, который вам нужен расширять? Если вы регулярно получаете новые книги со сжатыми данными, я бы поместил макрос в его книгу и указывал имя книги данных в качестве какого-то параметра.
3. Нет ли ошибок в данных? Например, если столбец E содержит 1.2.1, можете ли вы гарантировать, что столбец D содержит 1.2? Следует ли отбрасывать строку с ошибкой или код должен извлекать столько хороших данных, сколько нужно? Если он извлекает хорошие данные, что он делает с плохими?

Раньше я занимался подобными преобразованиями и нашел их интересной задачей. Я нашел вашу проблему намного более сложной, чем я ожидал. Вероятно, это произошло потому, что, если у меня не было полного контроля над исходными данными, я никогда не предполагал, что они были безошибочными. Если бы я запустил макрос для преобразования данных, я был бы не против, если бы ошибка вызвала ошибку sh. Если бы макрос должен был запускаться нетехническим пользователем, я бы избегал неудобных для пользователя сбоев.

Я создал некоторые тестовые данные на листе, который назвал «Источник». В вашем примере нет строки заголовка, но у меня есть. Ваш пример - первая строка данных. Затем я добавил еще несколько строк, некоторые из которых содержат ошибки.

Row|   A  |    B    |    C    |                    D                    |                 E                 |       F       |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  1|Region|Station  |N        |N.N                                      |N.N.N                              |N.N.N.N        |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  2|Reg1  |Station1 |1|2|3|4|5|1.1|1.2|1.3|2.1|3.1|4.1|4.2|5.1          |1.1.1|1.1.2                        |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  3|Reg1A |Station1A|1|2|3|4|5|1.1|1.2|1.3|2.1|3.1|4.1|4.2|5.1          |1.1.1|1.1.2|1.2.1                  |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  4|Reg2  |Station2 |1|2      |1.1|1.2|1.3|2.1|2.2|2.3|2.4              |1.1.1|1.1.2|1.2.1|1.3.1|1.3.2|2.1.1|1.3.1.1|1.3.1.2|
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  5|Reg3  |Station3 |1|3|10   |1.1|1.2|1.3|2.1|1.4|2.2|2.3|2.4|10.1|10.2|                                   |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  6|Reg4  |Station4 |A|1.2    |1.2.1                                    |A.B.C|1.2.1.1|1.2.1.2              |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  7|Reg5  |         |         |                                         |                                   |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  8|Reg6  |Station6 |         |                                         |                                   |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|
  9|Reg7  |Station7 |1|2      |                                         |                                   |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|

Результат на листе «Назначение»:

Row|   A  |    B    | C |  D  |   E   |   F   |
   |------+---------+---+-----+-------+-------|
  1|Region|Station  |N  |N.N  |N.N.N  |N.N.N.N|
   |------+---------+---+-----+-------+-------|
  2|Reg1  |Station1 |  1|  1.1|  1.1.1|       |
   |------+---------+---+-----+-------+-------|
  3|Reg1  |Station1 |  1|  1.1|  1.1.2|       |
   |------+---------+---+-----+-------+-------|
  4|Reg1  |Station1 |  1|  1.2|       |       |
   |------+---------+---+-----+-------+-------|
  5|Reg1  |Station1 |  1|  1.3|       |       |
   |------+---------+---+-----+-------+-------|
  6|Reg1  |Station1 |  2|  2.1|       |       |
   |------+---------+---+-----+-------+-------|
  7|Reg1  |Station1 |  3|  3.1|       |       |
   |------+---------+---+-----+-------+-------|
  8|Reg1  |Station1 |  4|  4.1|       |       |
   |------+---------+---+-----+-------+-------|
  9|Reg1  |Station1 |  4|  4.2|       |       |
   |------+---------+---+-----+-------+-------|
 10|Reg1  |Station1 |  5|  5.1|       |       |
   |------+---------+---+-----+-------+-------|
 11|Reg1A |Station1A|  1|  1.1|  1.1.1|       |
   |------+---------+---+-----+-------+-------|
 12|Reg1A |Station1A|  1|  1.1|  1.1.2|       |
   |------+---------+---+-----+-------+-------|
 13|Reg1A |Station1A|  1|  1.2|  1.2.1|       |
   |------+---------+---+-----+-------+-------|
 14|Reg1A |Station1A|  1|  1.3|       |       |
   |------+---------+---+-----+-------+-------|
 15|Reg1A |Station1A|  2|  2.1|       |       |
   |------+---------+---+-----+-------+-------|
 16|Reg1A |Station1A|  3|  3.1|       |       |
   |------+---------+---+-----+-------+-------|
 17|Reg1A |Station1A|  4|  4.1|       |       |
   |------+---------+---+-----+-------+-------|
 18|Reg1A |Station1A|  4|  4.2|       |       |
   |------+---------+---+-----+-------+-------|
 19|Reg1A |Station1A|  5|  5.1|       |       |
   |------+---------+---+-----+-------+-------|
 20|Reg2  |Station2 |  1|  1.1|  1.1.1|       |
   |------+---------+---+-----+-------+-------|
 21|Reg2  |Station2 |  1|  1.1|  1.1.2|       |
   |------+---------+---+-----+-------+-------|
 22|Reg2  |Station2 |  1|  1.2|  1.2.1|       |
   |------+---------+---+-----+-------+-------|
 23|Reg2  |Station2 |  1|  1.3|  1.3.1|1.3.1.1|
   |------+---------+---+-----+-------+-------|
 24|Reg2  |Station2 |  1|  1.3|  1.3.1|1.3.1.2|
   |------+---------+---+-----+-------+-------|
 25|Reg2  |Station2 |  1|  1.3|  1.3.2|       |
   |------+---------+---+-----+-------+-------|
 26|Reg2  |Station2 |  2|  2.1|  2.1.1|       |
   |------+---------+---+-----+-------+-------|
 27|Reg2  |Station2 |  2|  2.2|       |       |
   |------+---------+---+-----+-------+-------|
 28|Reg2  |Station2 |  2|  2.3|       |       |
   |------+---------+---+-----+-------+-------|
 29|Reg2  |Station2 |  2|  2.4|       |       |
   |------+---------+---+-----+-------+-------|
 30|Reg3  |Station3 |  1|  1.1|       |       |
   |------+---------+---+-----+-------+-------|
 31|Reg3  |Station3 |  1|  1.2|       |       |
   |------+---------+---+-----+-------+-------|
 32|Reg3  |Station3 |  1|  1.3|       |       |
   |------+---------+---+-----+-------+-------|
 33|Reg3  |Station3 |  1|  1.4|       |       |
   |------+---------+---+-----+-------+-------|
 34|Reg3  |Station3 |  3|     |       |       |
   |------+---------+---+-----+-------+-------|
 35|Reg3  |Station3 | 10| 10.1|       |       |
   |------+---------+---+-----+-------+-------|
 36|Reg3  |Station3 | 10| 10.2|       |       |
   |------+---------+---+-----+-------+-------|
 37|Reg3  |Station3 |-  |  2.1|       |       |
   |------+---------+---+-----+-------+-------|
 38|Reg3  |Station3 |-  |  2.2|       |       |
   |------+---------+---+-----+-------+-------|
 39|Reg3  |Station3 |-  |  2.3|       |       |
   |------+---------+---+-----+-------+-------|
 40|Reg3  |Station3 |-  |  2.4|       |       |
   |------+---------+---+-----+-------+-------|
 41|Reg4  |Station4 |A  |     |       |       |
   |------+---------+---+-----+-------+-------|
 42|Reg4  |Station4 |1.2|1.2.1|1.2.1.1|       |
   |------+---------+---+-----+-------+-------|
 43|Reg4  |Station4 |1.2|1.2.1|1.2.1.2|       |
   |------+---------+---+-----+-------+-------|
 44|Reg4  |Station4 |-  |-    |A.B.C  |       |
   |------+---------+---+-----+-------+-------|
 45|Reg5  |         |   |     |       |       |
   |------+---------+---+-----+-------+-------|
 46|Reg6  |Station6 |   |     |       |       |
   |------+---------+---+-----+-------+-------|
 47|Reg7  |Station7 |  1|     |       |       |
   |------+---------+---+-----+-------+-------|
 48|Reg7  |Station7 |  2|     |       |       |
   |------+---------+---+-----+-------+-------|

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

Большая часть кода c соответствует вашим требованиям. Однако я также включил FindLastRowCol из моей библиотеки. Большая часть кода разумно базовая c, но я использую массивы в качестве записей в виде коллекции более продвинуто. Если вы не понимаете синтаксис, я могу добавить учебник.

Option Explicit
Sub SplitColumns()

  ' * Create rows in the destination worksheet based on values in the source worksheet.
  ' * One source row may result in many destination rows.
  ' * Values in source columns 1 and 2 are copied unchanged to every destination row
  '   created from a source row.
  ' * Columns 3 onwards contain numbers separated by |s.
  ' * Column 3 contains integer values.
  ' * Column 4, if present, contains values of the form "integer.integer".
  ' * Each additional column adds another ".integer" to the value.
  ' * If a column contains "M.N ... Y.X", the preceding column should contain "M.N ... Y".
  ' * Source columns 3 onwards will be split so a destination row will contain
  '   colum 3 = "M", column 4 = "M.N", column 5 = "M.N.P" and so on.

  ' This assumes one header row in the source worksheet which will be copied to
  ' the destination worksheet. Replace 2 by the correct value as necessary.
  Const RowDataFirst As Long = 2

  ' The first column to be split.  Earlier columns are copied unchanged
  ' I avoid using literals in my code if there is any possibility that a future
  ' maintenence programmer will wonder what that literal is.  Named constants
  ' made the code easier to read. If a value could change, amending a constant
  ' is easier than searching thorugh the code for a literal.
  Const ColSplitFirst As Long = 3

  Dim ColCrnt As Long       ' \ Columns in source and
  Dim ColLast As Long       ' | destination worksheets
  Dim ColTemp As Long       ' / are the same
  Dim ColsParts As Variant
  Dim InxNumPart As Long
  Dim LenPartMax As Long
  Dim InxRP As Long
  Dim InxRPCol As Long
  Dim MatchFound As Long
  Dim NewRow() As String
  Dim NumParts(1 To 2) As String
  Dim PosDot As Long
  Dim RowDestCrnt As Long
  Dim RowsPending As Collection
  Dim RowSrcCrnt As Long    ' \ Rows in source and destination sheets are
  Dim RowSrcLast As Long    ' / different except when copying any header rows
  Dim WshtDest As Worksheet
  Dim WshtSrc As Worksheet

  Set WshtSrc = Worksheets("Source")
  Set WshtDest = Worksheets("Destination")

  ' Delete any existing data from destination worksheet
  WshtDest.Cells.EntireRow.Delete

  ' Copy any header rows for source to destination worksheets
  With WshtSrc
    For RowSrcCrnt = 1 To RowDataFirst - 1
      ' Find last column for this row
      ColLast = .Cells(RowSrcCrnt, .Columns.Count).End(xlToLeft).Column
      ' Copy row from source to destination worksheet. Note: for this loop
      ' source and destination rows are the same
      .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColLast)).Copy _
                                    Destination:=WshtDest.Rows(RowSrcCrnt)
    Next
  End With
  RowDestCrnt = RowDataFirst

  ' There are several methods of finding the last row and column of a worksheet
  ' none of which work in every situation. This routine tries every method and
  ' picks the best results
  Call FindLastRowCol(WshtSrc, RowSrcLast, ColLast)

  With WshtSrc
    For RowSrcCrnt = RowDataFirst To RowSrcLast

      ' Rows generated from the current source row are built in RowsPending.
      ' There is no ideal temporary storage for pending rows.  A new entry
      ' cannot be added in the middle of an array.  An existing entry cannot
      ' be amended in a collection.  A collection has been used because the
      ' ability to add new entries in the middle is essential.  Not being
      ' able update entries is merely a nuisance.
      ' Each entry is an array with entries for columns ColSplitFirst onwards.
      ' The collection is initialised from the values in ColSplitFirst and
      ' then updated for each subsequent column.
      Set RowsPending = New Collection

      ' Find last column for this row
      ColLast = .Cells(RowSrcCrnt, .Columns.Count).End(xlToLeft).Column
      If ColLast < ColSplitFirst Then
        ' No columns to be split.  Copy row to destination.
        .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColLast)).Copy _
                                           Destination:=WshtDest.Cells(RowDestCrnt, 1)
        RowDestCrnt = RowDestCrnt + 1
      Else
        ' Split splittable columns
        ReDim ColsParts(ColSplitFirst To ColLast)
        For ColCrnt = ColSplitFirst To ColLast
          ColsParts(ColCrnt) = Split(.Cells(RowSrcCrnt, ColCrnt), "|")
        Next

        ' Diagnostic code to check columns split correctly
        Debug.Print "Source row " & RowSrcCrnt
        For ColCrnt = ColSplitFirst To ColLast
          Debug.Print "  Column " & ColCrnt & ":";
          For InxNumPart = 0 To UBound(ColsParts(ColCrnt))
            Debug.Print "   " & ColsParts(ColCrnt)(InxNumPart);
          Next
          Debug.Print
        Next

        ' Initialise RowPending from first splittable column.
        For InxNumPart = 0 To UBound(ColsParts(ColSplitFirst))
          RowsPending.Add VBA.Array(ColsParts(ColSplitFirst)(InxNumPart))
        Next

        ' Diagnostic code to check RowsPending built correctly
        Debug.Print "Contents of RowsPending after being initialised from column " & ColSplitFirst
        For InxRP = 1 To RowsPending.Count
          Debug.Print "Row " & InxRP;
          For ColTemp = 0 To UBound(RowsPending(InxRP))
            Debug.Print "  " & RowsPending(InxRP)(ColTemp);
          Next
          Debug.Print
        Next

        ' Update RowPending for each additional splittable column.
        For ColCrnt = ColSplitFirst + 1 To ColLast
          ' Match each number within column against an existing row
          For InxNumPart = 0 To UBound(ColsParts(ColCrnt))
            ' Find last dot
            PosDot = InStrRev(ColsParts(ColCrnt)(InxNumPart), ".")
            ' Split number, such as M.N.P into two parts, M.N and P
            If PosDot = 0 Then
              ' No dot found
              Debug.Assert False
              NumParts(1) = ""                              ' No leading part
              NumParts(2) = ColsParts(ColCrnt)(InxNumPart)  ' Trailing part
              ' Note: NumParts(2) is extracted but is not currently used
            Else
              'Debug.Assert False
              ' Dot found
              NumParts(1) = Mid(ColsParts(ColCrnt)(InxNumPart), 1, PosDot - 1)
              NumParts(2) = Mid(ColsParts(ColCrnt)(InxNumPart), PosDot)
            End If
            ' Search down RowsPending for match with current part.
            InxRP = 1
            MatchFound = False
            For InxRP = 1 To RowsPending.Count
              If ColCrnt - ColSplitFirst = UBound(RowsPending(InxRP)) + 1 Then
                ' RowsPending(InxRP) has not been updated from this column.
                'Debug.Assert False
                If RowsPending(InxRP)(UBound(RowsPending(InxRP))) = NumParts(1) Then
                  ' Have a match.  First value from this column for this row.
                  'Debug.Assert False
                  ' Add current part to RowsPending(InxRP)
                  Call AddToRowInxRP(RowsPending, InxRP, ColsParts(ColCrnt)(InxNumPart))
                  MatchFound = True
                  Exit For
                End If
              ElseIf ColCrnt - ColSplitFirst = UBound(RowsPending(InxRP)) Then
                ' RowsPending(InxRP) has been updated from this column.
                'Debug.Assert False
                If RowsPending(InxRP)(UBound(RowsPending(InxRP)) - 1) = NumParts(1) Then
                  ' Have a match.  Already have a value from this column for this row.
                  'Debug.Assert False
                  Call AddRowAfterInxRP(RowsPending, InxRP, ColsParts(ColCrnt)(InxNumPart))
                  MatchFound = True
                  Exit For
                End If
              ElseIf ColCrnt - ColSplitFirst > UBound(RowsPending(InxRP)) Then
                ' This column was not updated for a previous column so cannot be a match
              Else
                ' This situation is not handled
                Debug.Assert False
              End If
            Next InxRP

            If Not MatchFound Then
              ' If the current value is M.N.P, No value M.N has been found in
              ' the immediate previous column.  Output the current value with
              ' hyphen in all previous columns.
              'Debug.Assert False
              ReDim NewRow(0 To ColCrnt - ColSplitFirst)
              For InxRPCol = 0 To ColCrnt - ColSplitFirst - 1
                NewRow(InxRPCol) = "-"
              Next
              NewRow(ColCrnt - ColSplitFirst) = ColsParts(ColCrnt)(InxNumPart)
              RowsPending.Add NewRow
            End If
          Next InxNumPart

          ' Diagnostic code to check RowsPending built correctly
          Debug.Print "Contents of RowsPending after adding values from column " & ColCrnt
          For InxRP = 1 To RowsPending.Count
            Debug.Print "Row " & InxRP;
            For ColTemp = 0 To UBound(RowsPending(InxRP))
              Debug.Print "  " & RowsPending(InxRP)(ColTemp);
            Next
            Debug.Print
          Next

        Next ColCrnt
      End If  ' ColLast < ColSplitFirst

      ' RowsPending is now ready to be output to the destination worksheet

      For InxRP = 1 To RowsPending.Count

        ' Copy unsplittable columns from source worksheet
        .Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColSplitFirst - 1)).Copy _
                                       Destination:=WshtDest.Cells(RowDestCrnt, 1)

        ' Columns 0 to UBound(RowsPending(InxRP)) of RowsPending(InxRP)are to be
        ' copied to columns ColSplitFirst onwards of Destination worksheet.
        ColCrnt = ColSplitFirst
        For InxRPCol = 0 To UBound(RowsPending(InxRP))
          WshtDest.Cells(RowDestCrnt, ColCrnt).Value = RowsPending(InxRP)(InxRPCol)
          ColCrnt = ColCrnt + 1
        Next
        RowDestCrnt = RowDestCrnt + 1

      Next

    Next RowSrcCrnt
  End With  ' WshtSrc

End Sub
Sub AddRowAfterInxRP(ByRef RowsPending As Collection, ByVal InxRP As Long, _
                     ByRef NewColValue As Variant)

  ' Add a new row to RowsPending based on and after RowsPending(InxRP).

  ' RowsPending(InxRP) has already been updated and it is possible that one or
  ' more following rows are updates of RowsPending(InxRP).  The new row is to
  ' be added after RowsPending(InxRP) and any updates based on it.

  Dim ColCrnt As Long
  Dim Extracted As Variant

  Do While True

    If InxRP = RowsPending.Count Then
      ' This is the last row of RowsPending so no further rows to check
      'Debug.Assert False
      Exit Do
    End If

    If UBound(RowsPending(InxRP)) > UBound(RowsPending(InxRP + 1)) Then
      ' The row InxRP+1 has not been updated so cannot be an
      ' updated version of row InxRP.
      'Debug.Assert False
      Exit Do
    End If

    For ColCrnt = LBound(RowsPending(InxRP)) To UBound(RowsPending(InxRP)) - 1
      If RowsPending(InxRP)(ColCrnt) <> RowsPending(InxRP + 1)(ColCrnt) Then
        ' Row InxRP+1 is not based on row InxRP
        'Debug.Assert False
        Exit Do
      End If
    Next

    ' Row InxRP+1 is based on row InxRP. So new row must be under row InxRP+1.
    ' Note: InxRP is passed by value so the updated value is not returned
    ' to the caller
    InxRP = InxRP + 1

  Loop

  ' InxRP is the last row with the same previous column as NewColValue.
  ' Use RowsPending(InxRP) as the basis of the new row which will be
  ' inserted under it.

  Extracted = RowsPending(InxRP)
  Extracted(UBound(Extracted)) = NewColValue
  If InxRP + 1 > RowsPending.Count Then
    RowsPending.Add Extracted              ' Add to end of RowsPending
  Else
    RowsPending.Add Extracted, , InxRP + 1 ' Add as entry InxRP+1
  End If

End Sub
Sub AddToRowInxRP(ByRef RowsPending As Collection, ByVal InxRP As Long, _
                  ByRef NewColValue As Variant)

  ' Add NewColValue to the array in RowsPending(InxRP)

  ' Entries in a collection cannot be updated.  The array within the current
  ' entry must be extracted and then updated. The current entry must then be
  ' replaced with the new array

  Dim Extracted As Variant

  Extracted = RowsPending(InxRP)
  ReDim Preserve Extracted(0 To UBound(Extracted) + 1)
  Extracted(UBound(Extracted)) = NewColValue
  RowsPending.Remove InxRP
  If InxRP > RowsPending.Count Then
    RowsPending.Add Extracted           ' Add to end of RowsPending
  Else
    RowsPending.Add Extracted, , InxRP  ' Add as entry InxRP
  End If

End Sub
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Variant)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would miss merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value about that found by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible?
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible?
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   * Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub

Answer 2

Попробуйте,

Sub test()
    Dim vDB, vR()
    Dim c, d, e
    Dim Ws As Worksheet, toWs As Worksheet
    Dim i As Long, r As Long, n As Long
    Dim k As Integer, j As Integer, m As Integer
    Dim s1 As String, s2 As String, s3 As String
    Dim cnt As Integer

    Set Ws = Sheets(1) '<~~ data sheet

    vDB = Ws.UsedRange

    r = UBound(vDB, 1)

    For i = 2 To r
        c = Split(vDB(i, 3), "|")
        d = Split(vDB(i, 4), "|")
        e = Split(vDB(i, 5), "|")
        For k = 0 To UBound(c)
            For j = 0 To UBound(d)
                s1 = c(k)
                s2 = Split(d(j), ".")(0)
                If s1 = s2 Then
                    n = n + 1
                    ReDim Preserve vR(1 To 5, 1 To n)
                    vR(1, n) = vDB(i, 1)
                    vR(2, n) = vDB(i, 2)
                    vR(3, n) = s1
                    vR(4, n) = d(j)
                    cnt = 0
                    For m = 0 To UBound(e)
                        'cnt = cnt + 1
                        s3 = Left(e(m), Len(e(m)) - 2)
                        If d(j) = s3 Then
                            cnt = cnt + 1
                            If cnt = 1 Then
                                vR(5, n) = e(m)
                            Else
                                n = n + 1
                                ReDim Preserve vR(1 To 5, 1 To n)
                                vR(1, n) = vDB(i, 1)
                                vR(2, n) = vDB(i, 2)
                                vR(3, n) = s1
                                vR(4, n) = d(j)
                                vR(5, n) = e(m)
                            End If
                        Else
                            cnt = 0
                        End If
                    Next m
                End If
            Next j
        Next k
    Next i
    Set toWs = Sheets(2) '<~~ Result sheet
    With toWs
        .UsedRange.Clear
        .Range("a1").Resize(1, 5) = Ws.Range("a1").Resize(1, 5).Value
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With
End Sub