首先是关于你的代码和问题的一些 cmets。
切勿在现场尝试像这样的工作表转换。如果您的代码失败，您已经破坏了源工作表。如果您有备份，则可以恢复源工作表，但这很麻烦。在新工作表中构建新格式要容易得多。
您没有提供足够的背景来完全理解您的要求：
- 您只提供了一个示例行，但您的代码似乎可以处理多行。要处理多少行？如果有数十万行，效率会比只有几百行更重要。
- 您是否有要转换的工作表，或者您是否定期收到需要扩展的这种压缩格式的数据？如果您定期收到带有压缩数据的新工作簿，我会将宏放在其工作簿中，并将数据工作簿的名称作为某种参数。
- 数据没有错误吗？例如，如果 E 列包含 1.2.1，您能否保证 D 列包含 1.2？是否要丢弃有错误的行，或者代码是否应该提取尽可能多的好数据？如果它提取了好的数据，那么它如何处理坏数据呢？
我曾经处理过这样的转换，并发现它们是一个有趣的挑战。我发现您的问题比我预期的更具挑战性。这可能是因为除非我完全控制源数据，否则我永远不会认为它没有错误。如果我运行宏来转换数据，我不会介意错误是否导致它崩溃。如果宏由非技术用户运行，我会避免非用户友好的失败。
我在名为“Source”的工作表中创建了一些测试数据。您的示例不包括标题行，但我有。您的示例是第一个数据行。然后我又添加了一些有错误的行。
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| | | |
|------+---------+---+-----+-------+-------|
示例行的输出与您所需的输出相匹配。我的其他行的输出与您的示例一致。我试图以友好的方式处理错误。
大部分代码都特定于您的要求。但是，我还从我的库中包含了FindLastRowCol。大多数代码都是相当基本的，但我使用数组作为条目是一个更高级的集合。如果你不明白语法，我可以添加一个教程。
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