的樣本數據
的聯繫信息的立式清單將被直接價值轉移是最方便處理。
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
我將它留給你來決定哪種方法適合你的目的。
SO上沒有私人消息功能,但您可以留下評論引導某人訪問該圖片。 –