將5列從一個表到另一個地方，但到

Question

一排我有我需要拉一個數據源5列：
Line1|Line2|Line3|Line4|Line5

...所有在他們之下的數據。我需要將這5列添加到新工作表中，不僅要重命名它們，還要爲每條記錄創建更多列。

如：
shop1|add1|citystate1|phone1|web1|shop2|add2|citystate2|phone2|web2| etc.

...與數據的相應列下下降。每個記錄的列僅相同。

屏幕截圖

數據源圖像是什麼數據的模樣了。除了我將這些列複製出原來的外，因爲還有其他列。我只需要那5列。

結果圖像是我需要它結束了。可能會有數百條記錄。標題需要按順序顯示。我只包括前幾列，但是這些列橫向延伸了幾條記錄。

Answer 1

的Concatenate功能可能會做你想要什麼。

Answer 2

^{的樣本數據}

的聯繫信息的立式清單將被直接價值轉移是最方便處理。

Sub moveShiftLaterally_Values() 
    Dim strHDR As String, rw As Long, cls As Long, vHDRs As Variant 

    strHDR = "shop0|add0|citystate0|phone0|web0" 

    Worksheets("Sheet1").Copy After:=Worksheets("Sheet1") 
    ActiveSheet.Name = "horizList" 

    With Worksheets("horizList") 
     For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 
      'assign the correct increment and split the header string 
      vHDRs = Split(Replace(strHDR, 0, rw - 1), Chr(124)) 
      'transfer the headers 
      .Cells(1, 1).Offset(0, (rw - 2) * (UBound(vHDRs) + 1)).Resize(1, UBound(vHDRs) + 1) = vHDRs 
      'transfer the values 
      .Cells(2, 1).Offset(0, (rw - 2) * (UBound(vHDRs) + 1)).Resize(1, UBound(vHDRs) + 1) = _ 
       .Cells(rw, 1).Resize(1, UBound(vHDRs) + 1).Value 
     Next rw 
     'remove the original entries 
     .Cells(1, 1).CurrentRegion.Offset(2, 0).Clear 
    End With 

End Sub 

^{後moveShiftLaterally_Values}

然而，隨着自定義數字可能性格式化的電話號碼和不同的是應水平勻漿列寬，加入Range.PasteSpecial method的某些XlPasteType面到第一晶種目的地細胞可能最終被證明是最好的方法。

Sub moveShiftLaterally_All() 
    Dim strHDR As String, rw As Long, cls As Long, vHDRs As Variant 

    strHDR = "shop0|add0|citystate0|phone0|web0" 

    Worksheets("Sheet1").Copy After:=Worksheets("Sheet1") 
    ActiveSheet.Name = "horizList" 

    With Worksheets("horizList") 
     'seed the cell formats and column widths first 
     With .Cells(1, 1).CurrentRegion 
      With .Resize(2, .Columns.Count) 
       .Copy 
       For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 
        'transfer the column widths and cell formatting 
        .Cells(1, 1).Offset(0, (rw - 2) * .Columns.Count).PasteSpecial _ 
         Paste:=xlPasteColumnWidths 
        .Cells(1, 1).Offset(0, (rw - 2) * .Columns.Count).PasteSpecial _ 
         Paste:=xlPasteFormats 
       Next rw 
       Application.CutCopyMode = False 
      End With 
     End With 
     'transfer the HDR and VALs 
     For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 
      'assign the correct increment and split the header string 
      vHDRs = Split(Replace(strHDR, 0, rw - 1), Chr(124)) 
      'transfer the headers 
      .Cells(1, 1).Offset(0, (rw - 2) * (UBound(vHDRs) + 1)).Resize(1, UBound(vHDRs) + 1) = vHDRs 
      'transfer the values 
      .Cells(2, 1).Offset(0, (rw - 2) * (UBound(vHDRs) + 1)).Resize(1, UBound(vHDRs) + 1) = _ 
       .Cells(rw, 1).Resize(1, UBound(vHDRs) + 1).Value 
     Next rw 
     'remove the original entries 
     .Cells(1, 1).CurrentRegion.Offset(2, 0).Clear 
    End With 

End Sub 

^{後moveShiftLaterally_Values}

我將它留給你來決定哪種方法適合你的目的。