Question

我需要提取一个数据源中的5列：
Line1|Line2|Line3|Line4|Line5

...所有数据都在他们之下。我需要将这5列拉入新表中，不仅要重命名它们，还要为每条记录创建更多列。

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

...数据落在相应的列下。对于每条记录，列只是相同的顺序。

屏幕截图

数据源图像是现在的数据。除非我将这些列复制出原始列，因为还有其他列。我只需要那5列。

结果图像是我最终需要它的方式。可能会有数百条记录。标题需要是顺序的，如图所示。我只包含前几列，但这些列水平延伸了几个记录。

Answer 1

^样本数据

通过直接价值转移可以最方便地处理长的垂直联系信息列表。

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}

但是，由于电话号码和不同列宽的自定义数字格式可能会水平均匀化，因此将XlPasteType的某些Range.PasteSpecial method方面添加到第一粒播种目标小区可能最终证明是最好的方法。

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}

我会留给你决定哪种方法适合你的目的。

Answer 2

Concatenate函数可能会执行您想要的操作。

将5列从一个工作表移动到另一个工作表但放入一行

2 个答案: