コンテンツを移動して1つの列からセルを分離する

Question

最近、大きなシートが再フォーマットされました。私はvbaにあまり精通していませんが、私はいくつかのことを知っていて、できる限りベストを尽くしました。

これには、電話番号、いくつかの電子メールアドレス、およびウェブサイトを持つ列があります。

私はあなたにそれがどのように、どのようにあるべきか、そしてどれだけ遠くにあるべきかの小さな例を示しました。あなたが見ることができるように

私は Id後に2つの列を挿入し、 Phone number、 E-Mailsと Websiteにヘッダーの名前を変更しました。番号を移動することは本当に難しいことではありませんでしたが、私は電子メールアドレスとウェブサイトを移動する際に苦労しています。オリジナルシート Id、 Phone numberで

、...左上（Id A1、B1 Phone number、...）である

空の行がファイルにありません。電子メールアドレスとウェブサイトの違いを見つけるには、セルに@が含まれているかどうかを調べます。誰かが私に、我々はコードを見ることができない場合は、私たちが支援するためにハード

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