Macro Excel: split cell values by multiple columns into multiple rows and keep other data

Question

Reproducible example:

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

Desired output:

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 

I have tried this solution: Split cell values into multiple rows and keep other data

But it doesn't apply to split rows by multiple column values.

So I tried this:

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

Only values in the ColC were splitted, and I need an output like the one above.

Answer 1

Try,

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

Answer 2

First some comments on your code and question.

Never attempt a worksheet transformation like this in situ. If your code fails, you have destroyed your source worksheet. If you have a backup, you can restore your source worksheet but that is a nuisance. It is so much easier to build the new format in a new worksheet.

You do not provide enough background to fully understand your requirement:

1. You provide only one example row, but your code appears to handle multiple rows. How many rows are to be processed? If there are hundreds of thousands of rows, efficiency would be more important that if there are only a few hundred.
2. Do you have one worksheet to be transformed or do you regularly receive data in this compressed format which you need to expand? If you regularly receive new workbooks with the compressed data, I would place the macro in its on workbook and have the name of the data workbooks as some sort of parameter.
3. Is the data error free? For example, if column E contains 1.2.1, can you guarantee that column D contains 1.2? Is a row with an error to be discarded or should the code extract as much good data as it should? If it extracts the good data, what does it do with the bad data?

I used to tackle transformations like this and found them an interesting challenge. I found your problem much more challenging than I expected. This was probably because unless I had total control over the source data, I will never assume it was error free. If I ran the macro to transform the data, I would not mind if an error caused it to crash. If the macro was to be run by a non-technical user, I would avoid non-user-friendly failures.

I created some test data in a worksheet I named “Source”. Your example does not include a header row but I have. Your example is the first data row. I have then added some further rows some with errors.

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      |                                         |                                   |               |
   |------+---------+---------+-----------------------------------------+-----------------------------------+---------------|

The output to worksheet “Destination” is:

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|     |       |       |
   |------+---------+---+-----+-------+-------|

The output for your example row matches your required output. The output for my other rows is consistent with your example. I have tried to handle errors in a friendly manner.

Most of the code is specific to your requirement. However, I have also included FindLastRowCol from my library. Most of the code is reasonably basic but my use of arrays as entries is a collection is more advanced. If you do not understand the syntax, I can add a tutorial.

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