将内容移动到一列中分隔单元格

最近我得到了一个大的表来重新格式化。 我不是很熟悉vba，但我知道一些东西，尽我所能。

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

我给你提供了一个小例子，它是如何发生的以及我走了多远。

正如你所看到的，我在Id后插入了两列，并将标题重命名为Phone number ， E-Mails和Website 。 移动这个号码并不是很难，但我在移动电子邮件地址和网站时很费劲。

在原始图纸Id ， Phone number …在左上angular（ Id A1， Phone number B1，…）

文件中没有空行。 find电子邮件地址和网站之间的差异是通过查看单元格是否包含@ 。 如果有人能帮助我，那将是非常棒的

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