将内容移动到一列中的单独单元格

Question

最近我有一张重新格式化的表格。我对vba不是很熟悉，但我知道一些事情并尽我所能。

它有一个列，其中包含电话号码，一些电子邮件地址和一个网站。

我为你提供了一个小例子，它是如何形成的，它应该如何以及我走了多远。

如您所见，我在Id之后插入了两列，并将标题重命名为Phone number，E-Mails和Website。移动数字并不是很难，但我在移动电子邮件地址和网站方面很挣扎。

在原始工作表Id中，Phone number，...位于左上角（Id A1，Phone number B1，...）

文件中没有空行。通过查看单元格是否包含@来查找电子邮件地址与网站之间的差异。如果有人可以帮助我会很棒

Answer 1

Sub RearangeWorkSheet2()
    Const IDColumn = 1
    Dim arrData()
    Dim i As Long, j As Long, RecordID As Long, lastRow As Long, x As Long, y As Long

    lastRow = Range("B" & Rows.Count).End(xlUp).row
    ReDim arrData(3, 0)

    For x = 2 To lastRow
        If Cells(x, 1) <> "" Then
            RecordID = i
            ReDim Preserve arrData(3, i)
            arrData(0, RecordID) = Cells(x, 1)
            i = i + 1
        End If

        If IsNumeric(Left(Cells(x, 2), 3)) Then
            y = 1
        ElseIf InStr(Cells(x, 2), "@") Then
            y = 2
        Else
            y = 3
        End If

        For j = RecordID To UBound(arrData, 2)

            If IsEmpty(arrData(y, j)) Or j = UBound(arrData, 2) Then Exit For

        Next

        If Not IsEmpty(arrData(y, j)) Then
            ReDim Preserve arrData(3, i)
            i = i + 1
            j = j + 1
        End If

        arrData(y, j) = Cells(x, 2)
    Next

    Worksheets("Sheet1").Range("D2").Resize(UBound(arrData, 2) + 1, 4).Value = WorksheetFunction.Transpose(arrData)

End Sub