Excel VBA将数据从一个单元格转换为行（types不匹配错误）
我第一次创build一个macrosVBA excel。 我有包含4列的表格如下：
Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 396035:835253:907794 我想分开它们，以便输出结果是：
Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 396035 Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 835253 Determining the Geometry of Boundaries of Objects from Medial Data | James N. Damon | 907547 | 907794
我使用的macros如下（从stackoverflow引用），但我有一个types不匹配错误的行
[e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)
任何帮助将非常感激。 这是我第一次和VBA打交道，对于types不匹配的问题，这似乎很空白。
Sub SliceNDice() Dim objRegex As Object Dim X Dim Y Dim lngRow As Long Dim lngCnt As Long Dim tempArr() As String Dim strArr Set objRegex = CreateObject("vbscript.regexp") objRegex.Pattern = "^\s+(.+?)$" 'Define the range to be analysed X = Range([a1], Cells(Rows.Count, "d").End(xlUp)).Value2 ReDim Y(1 To 4, 1 To 1000) For lngRow = 1 To UBound(X, 1) 'Split each string by "," tempArr = Split(X(lngRow, 4), ",") For Each strArr In tempArr lngCnt = lngCnt + 1 'Add another 1000 records to resorted array every 1000 records If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(1 To 4, 1 To lngCnt + 1000) Y(1, lngCnt) = X(lngRow, 1) Y(2, lngCnt) = X(lngRow, 2) Y(3, lngCnt) = X(lngRow, 3) Y(4, lngCnt) = objRegex.Replace(strArr, "$1") Next Next lngRow 'Dump the re-ordered range to columns E:H [e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y) ActiveSheet.Range("E:H").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _ Header:=xlNo End Sub
而我的文件是由成千上万的行组成的。
这是一种方法。 不是最快的，但做的工作。 我已经评论了代码，所以你不会理解它的问题。
Sub Sample() Dim ws As Worksheet Dim lRow As Long, i As Long, j As Long Dim tmpAr As Variant '~~> Change this to the relevant sheet Set ws = ThisWorkbook.Sheets("Sheet1") With ws '~~> Get last row in Col D. That is where we have to check for ":" lRow = .Range("D" & .Rows.Count).End(xlUp).Row '~~> Reverse loop the rows For i = lRow To 1 Step -1 '~~> Check if cell in Col D has ":" If InStr(1, .Range("D" & i).Value, ":") Then '~~> Split on ":" and store in an array tmpAr = Split(.Range("D" & i).Value, ":") '~~> Loop through the array For j = LBound(tmpAr) To UBound(tmpAr) '~~> Insert a row in the next row .Rows(i + 1).Insert Shift:=xlDown, _ CopyOrigin:=xlFormatFromLeftOrAbove '~~> Copy data from above as cell in Col D is different .Rows(i).Copy .Rows(i + 1) '~~> Add the new value to cell in Col D .Cells(i + 1, 4).Value = tmpAr(j) Next j '~~> Delete the row .Rows(i).Delete End If Next i End With End Sub
截图
