Excel VBA将数据从一个单元格转换为行（类型不匹配错误）

debugcn 发表于 Dev

紫红色

我是第一次创建宏VBA 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

我使用的宏如下（来自stackoverflow中的引用），但是我在行上遇到类型不匹配错误

[e1].Resize(lngCnt, 4).Value2 = Application.Transpose(Y)

任何帮助将非常感激。这是我第一次处理VBA，对于类型不匹配，这对我来说似乎是一片空白。

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

我的文件包含成百上千的行。

悉达思·劳特（Siddharth Rout）

这是一种方法。不是最快的，但能完成任务。我已经注释了代码，因此您在理解它时不会遇到问题。

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