更好的方法来拆分多个行中的单元格值，并使用Excel-VBA完整格式化在下一列中连接这些值 [英] Better method to Split Cell values in multiple Rows and Concatenate these values in the next Column with formatting intact using Excel-VBA
问题描述
这是我的Excel工作表的视图:
文档概述:
它具有多个列，这些列可能会根据要求而有所不同.每张工作表中始终提供文档ID和文档版本，但是列名称(Ex; Doc ID或ID/Doc Version或Doc#)和列(例如，G列和H列/J列和K列)可能会有所不同.
在这种情况下，文档ID-C列和文档版本-D列可能在每个单元格中包含多个值.
文档ID始终有9位数字(如果Id没有足够的数字，则用尾随零填充).前任; 000 987094、123456100、234567899， 0 23456789等
文档版本始终具有固定格式"0.0"或"00.0"，例如； 1.0、23.0、2.1等.
我到目前为止所做的描述:
我使用VBA宏将包含多个值(ID和相关版本，在上传的图像中突出显示)的单元格拆分为它们下方的行.之后，通过手动插入新列，然后使用另一个宏进行串联，将拆分值连接到下一列.
这是我运行宏后的输出:
宏:
Sub SplitCellValuesIntoRows()
Dim rng_all_data As Range
'Set rng_all_data = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
Set rng_all_data = ActiveSheet.UsedRange
Dim int_row As Integer
int_row = 0
On Error Resume Next
Dim sht_out As Worksheet
Set sht_out = Worksheets.Add
Dim rng_row As Range
For Each rng_row In rng_all_data.Rows
Dim int_col As Integer
int_col = 0
Dim int_max_splits As Integer
int_max_splits = 0
Dim rng_col As Range
For Each rng_col In rng_row.Columns
Dim col_parts As Variant
col_parts = Split(rng_col, vbLf)
If UBound(col_parts) > int_max_splits Then
int_max_splits = UBound(col_parts)
End If
sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)
int_col = int_col + 1
Next
int_row = int_row + int_max_splits + 1
Next
End Sub
Sub Join_em()
For i = 2 To ActiveSheet.UsedRange.Rows.Count
Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)
Next i
End Sub
在宏Join_em()中，在使用第一个宏SplitCellValuesIntoRows()之后，根据文档ID和文档版本的输出列，手动填充值以获取串联值.
Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)
在这种情况下为
C，D 和 E .
我要实现的目标:
我正在尝试实现类似这样的输出:
- 通过在同一张纸中添加行来拆分具有多个值的单元格，并使目标单元格保持格式不变.
- 添加一个新列 E(在这种情况下)，然后将文档ID和文档版本中的值连接在一起，并保留前导零和尾随零.
- 由于文档ID(9位数字带有/不带尾随零)和文档版本("0.0"或"00.0")的格式始终固定，但是名称和列号不固定，是否可以使用正则表达式并将多个单元格值拆分为单独的行后，自动将相应的单元格合并到它们旁边新插入的列中. (了解如何使它正常工作真是太棒了，我已经尝试过但没有成功.我不知道使它工作的逻辑)
这里是用于下载虚拟Excel表格的链接，以备不时之需.
查找列
Regex解决方案在寻找复杂的字符串组合时非常有用，但是在VBA中，它们可能会有点慢.鉴于匹配模式的简单性，使用更多原始"字符串比较可能会更容易，更快捷.例如，假设您的文档ID在10000到1000000000之间，您可以简单地尝试将字符串转换为Long，然后查看该值是否在这些数字之间.在比较文档版本时，可以使用类似的方法比较小数点的每一边.
使用任何字符串比较(Regex或其他方式)，您需要防止错误的匹配.例如，单元格"A3"的值与文档版本的模式匹配.因此，您需要采取一些保护措施，以防止您的代码选择错误的列.只有您会知道这些可靠地是什么，但这可能只是说文档版本只能出现在"C"列中或之后.
连接值
在电子表格中，所有单元格的格式均为Text.这意味着偶数将被解释为字符串-因此，绿色小三角形会在ID和版本单元格中向您发出警告.如果它们是数字，那么您需要对这些单元格应用数字格式(例如，版本的#0.#).对于您的电子表格，串联并没有像str = str1 & " " & str2中那样连接两个字符串那样复杂.
在第二张图像中，看起来好像您具有General单元格格式(或某种数字格式)，因此这些值被解释为数字.这些需要在连接之前使用NumberFormat()函数进行格式化.
拆分行
将单元格分成几行，尽管从语法上讲很容易，但是当您试图跟踪要调查的哪一行时，可能会很麻烦.我这样做的方法是将相关的行存储在Collection中，并在需要时不断引用那些收集对象.这样做的好处是，只要添加行，Collection中的Range引用就会自动更新.
总而言之，您的代码相对简单，下面给出了一个示例.您会注意到，我没有理会新行和新列的格式-这是相当琐碎的，您可以根据自己的需要做一些事情.此代码应放在模块中:
Option Explicit
Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2
Private Sub RunMe()
Dim data As Variant, cols As Variant, items As Variant
Dim r As Long, c As Long, i As Long, n As Long
Dim ids() As String, vers() As String
Dim addItems As Collection, concatItems As Collection
Dim dataRng As Range, rng As Range
Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
Dim dataStartRow As Long
'Define the range we're interested in and read into an array.
With Sheet1 'adjust for your worksheet object
Set dataRng = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column)
End With
data = dataRng.Value2
dataStartRow = 2
'Find the two target columns
cols = AcquireIdAndVerCol(data, 3, 8)
If IsEmpty(cols) Then
MsgBox "Unable to find Id and Ver columns."
Exit Sub
End If
With dataRng
'Add a column next to the version number column.
.Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Add a column to our range.
'This is to cover the case that the rightmost column is the version number column.
Set dataRng = .Resize(, .Columns.Count + 1)
End With
'Find the rows that need to be split and concatenate the target strings.
Set addItems = New Collection
Set concatItems = New Collection
For r = dataStartRow To UBound(data, 1)
ids = Split(data(r, cols(ID_IDX)), vbLf)
vers = Split(data(r, cols(VER_IDX)), vbLf)
n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))
If n = 0 Then 'it's just one line of text.
'Add concatenated text to list.
concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))
ElseIf n > 0 Then 'it's multiple lines of text.
'Transpose the id array.
ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeID(i + 1, 1) = ids(i)
Next
'Transpose the version array.
ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeVer(i + 1, 1) = vers(i)
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Else 'it's an empty cell
'Add empty item to concatenated list in order to keep alignment.
concatItems.Add Empty
End If
Next
Application.ScreenUpdating = False
'Split the ranges in the list.
If addItems.Count > 0 Then
For Each items In addItems
'Add the rows.
With items(RNG_IDX)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
'Note: format your rng Range obect as desired here.
End With
'Write the id and version values.
rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
Next
End If
'Write the concatenated values.
If concatItems.Count > 0 Then
ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
'Header to array.
writeConcat(1, 1) = "Concat values"
'Values from the collection to array.
i = dataStartRow
For Each items In concatItems
writeConcat(i, 1) = items
i = i + 1
Next
'Output array to range.
With dataRng.Columns(cols(VER_IDX) + 1)
.Value = writeConcat
.AutoFit
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
Dim result(1) As Long
Dim r As Long, c As Long, i As Long
Dim items() As String
'Check we're not operating outside bounds of data array.
If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)
'Loop through data to find the two columns.
'Once found, leave the function.
For r = 1 To UBound(data, 1)
For c = minCol To maxCol
items = Split(data(r, c), vbLf)
For i = 0 To UBound(items)
If result(ID_IDX) = 0 Then
If IsDocId(items(i)) Then
result(ID_IDX) = c
If result(VER_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
If result(VER_IDX) = 0 Then
If IsDocVer(items(i)) Then
result(VER_IDX) = c
If result(ID_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
Next
Next
Next
End Function
Private Function IsDocId(val As String) As Boolean
Dim n As Long
n = TryClng(val)
IsDocId = (n > 9999 And n <= 999999999)
End Function
Private Function IsDocVer(val As String) As Boolean
Dim n As Long, m As Long
Dim items() As String
items = Split(val, ".")
If UBound(items) <> 1 Then Exit Function
n = TryClng(items(0))
m = TryClng(items(1))
IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function
'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
Dim n As Long
n = fail
On Error Resume Next
n = CLng(expr)
On Error GoTo 0
TryClng = n
End Function
Here is the view of my excel sheet:
Document Overview:
It has multiple columns which may vary as per the requirement.Document ID's and Document Versions are always available in each sheet, however the Name of the Column (Ex; Doc ID or ID / Doc Version or Doc #) and Columns (Ex; Column G & H / Column J & K) may vary.
In this case, Document ID - Column C and Document version - Column D may contain multiple values in each cell.
Document Id always has 9 digits (filled with trailing zeros if the Id does not have enough digits). Ex; 000987094, 123456100 , 234567899, 023456789 etc.
Document Version always has the fixed format of "0.0" or "00.0", Ex; 1.0, 23.0, 2.1 etc.
Description of what I have done so far:
I use VBA Macro to split the Cells containing multiple values (ID and related Versions, highlighted in the uploaded image) into rows below them. After that I Concatenate the Split Values into next column by inserting a new column manually and then using another Macro to Concatenate.
Here is the Output after I run the Macro:
Macros:
Sub SplitCellValuesIntoRows()
Dim rng_all_data As Range
'Set rng_all_data = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
Set rng_all_data = ActiveSheet.UsedRange
Dim int_row As Integer
int_row = 0
On Error Resume Next
Dim sht_out As Worksheet
Set sht_out = Worksheets.Add
Dim rng_row As Range
For Each rng_row In rng_all_data.Rows
Dim int_col As Integer
int_col = 0
Dim int_max_splits As Integer
int_max_splits = 0
Dim rng_col As Range
For Each rng_col In rng_row.Columns
Dim col_parts As Variant
col_parts = Split(rng_col, vbLf)
If UBound(col_parts) > int_max_splits Then
int_max_splits = UBound(col_parts)
End If
sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)
int_col = int_col + 1
Next
int_row = int_row + int_max_splits + 1
Next
End Sub
Sub Join_em()
For i = 2 To ActiveSheet.UsedRange.Rows.Count
Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)
Next i
End Sub
In the macro Join_em(), I fill the values manually after using the first Macro SplitCellValuesIntoRows(), based on the output columns of Document ID and Document Version to get the Concatenated values.
Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)
C, D and E in this case.
What I want to achieve:
I am trying to achieve something like this as the output:
- Split the Cells with multiple values by adding rows in the same sheet and keep the destination cell formatting intact.
- Add a new Column E (in this case) and Concatenate the values from Document ID and Document Version with the leading and trailing zeroes intact.
- Since the format for Document ID (9 digits with/without trailing zeroes) and Document versions ("0.0" or "00.0") are always fixed, but the Name and Column # are not fixed, Is it possible to use regex and combine the respective cells into newly inserted column beside them automatically after splitting multiple cell values into individual rows. (It would be awesome to get to know how to make it work,I have tried it without success. I don't know the logic to make it work)
Here is the link for downloading the dummy Excel Sheet, in case it is needed for clarity.
Finding your columns
Regex solutions are extremely useful when you are looking for complex string combinations, but in VBA they can be a little slow. Given the simplicity of your match patterns, it'd probably easier and faster to use more 'primitive' string comparisons. Say, for example, your Document Id's are between 10000 and 1000000000, you could simply try to convert your string to a Long and see if the value is between those numbers. A similar approach could be used comparing each side of a decimal for your Document Version comparison.
With any string comparison, Regex or otherwise, you need to guard against false matches. The value of cell "A3", for example, matches the pattern of a Document Version. So you need to put in place some safeguards to prevent your code selecting the wrong column; only you will know what those could reliably be, but it might be something as simple as saying a Document Version can only occur in Column "C" or after.
Concatenating the values
In your spreadsheet, all cells are formatted as Text. This means that even numbers will be interpreted as strings - hence the little green triangle warning you of this in your ID and Version cells. Had they been numbers, then you'd have needed to apply a number format to those cells (eg #0.# for the Version). For your spreadsheet, concatenation is no more complicated than joining the two strings as in str = str1 & " " & str2.
In your second image, it looks as though you have a General cell format (or perhaps some kind of number format) so those values are interpreted as numbers. These would need to be formatted before concatenation, using the NumberFormat() function.
Splitting the rows
Splitting cells into rows, although syntactically easy, can be fiddly when you're trying to keep track of which row you're investigating. The way that I do it is to store the pertinent rows in a Collection and I keep referencing those collection objects as I need them. The advantage of this is that the Range reference in the Collection updates itself whenever rows are added.
All in all, then, your code is relatively straightforward and an example of how it could work is given below. You'll note that I haven't bothered formatting the new rows and columns - that's fairly trivial and is something you could do yourself to suit your own needs. This code should be put in a Module:
Option Explicit
Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2
Private Sub RunMe()
Dim data As Variant, cols As Variant, items As Variant
Dim r As Long, c As Long, i As Long, n As Long
Dim ids() As String, vers() As String
Dim addItems As Collection, concatItems As Collection
Dim dataRng As Range, rng As Range
Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
Dim dataStartRow As Long
'Define the range we're interested in and read into an array.
With Sheet1 'adjust for your worksheet object
Set dataRng = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column)
End With
data = dataRng.Value2
dataStartRow = 2
'Find the two target columns
cols = AcquireIdAndVerCol(data, 3, 8)
If IsEmpty(cols) Then
MsgBox "Unable to find Id and Ver columns."
Exit Sub
End If
With dataRng
'Add a column next to the version number column.
.Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Add a column to our range.
'This is to cover the case that the rightmost column is the version number column.
Set dataRng = .Resize(, .Columns.Count + 1)
End With
'Find the rows that need to be split and concatenate the target strings.
Set addItems = New Collection
Set concatItems = New Collection
For r = dataStartRow To UBound(data, 1)
ids = Split(data(r, cols(ID_IDX)), vbLf)
vers = Split(data(r, cols(VER_IDX)), vbLf)
n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))
If n = 0 Then 'it's just one line of text.
'Add concatenated text to list.
concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))
ElseIf n > 0 Then 'it's multiple lines of text.
'Transpose the id array.
ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeID(i + 1, 1) = ids(i)
Next
'Transpose the version array.
ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeVer(i + 1, 1) = vers(i)
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Else 'it's an empty cell
'Add empty item to concatenated list in order to keep alignment.
concatItems.Add Empty
End If
Next
Application.ScreenUpdating = False
'Split the ranges in the list.
If addItems.Count > 0 Then
For Each items In addItems
'Add the rows.
With items(RNG_IDX)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
'Note: format your rng Range obect as desired here.
End With
'Write the id and version values.
rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
Next
End If
'Write the concatenated values.
If concatItems.Count > 0 Then
ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
'Header to array.
writeConcat(1, 1) = "Concat values"
'Values from the collection to array.
i = dataStartRow
For Each items In concatItems
writeConcat(i, 1) = items
i = i + 1
Next
'Output array to range.
With dataRng.Columns(cols(VER_IDX) + 1)
.Value = writeConcat
.AutoFit
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
Dim result(1) As Long
Dim r As Long, c As Long, i As Long
Dim items() As String
'Check we're not operating outside bounds of data array.
If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)
'Loop through data to find the two columns.
'Once found, leave the function.
For r = 1 To UBound(data, 1)
For c = minCol To maxCol
items = Split(data(r, c), vbLf)
For i = 0 To UBound(items)
If result(ID_IDX) = 0 Then
If IsDocId(items(i)) Then
result(ID_IDX) = c
If result(VER_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
If result(VER_IDX) = 0 Then
If IsDocVer(items(i)) Then
result(VER_IDX) = c
If result(ID_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
Next
Next
Next
End Function
Private Function IsDocId(val As String) As Boolean
Dim n As Long
n = TryClng(val)
IsDocId = (n > 9999 And n <= 999999999)
End Function
Private Function IsDocVer(val As String) As Boolean
Dim n As Long, m As Long
Dim items() As String
items = Split(val, ".")
If UBound(items) <> 1 Then Exit Function
n = TryClng(items(0))
m = TryClng(items(1))
IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function
'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
Dim n As Long
n = fail
On Error Resume Next
n = CLng(expr)
On Error GoTo 0
TryClng = n
End Function
这篇关于更好的方法来拆分多个行中的单元格值，并使用Excel-VBA完整格式化在下一列中连接这些值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
