我需要在VBA中格式化数据

Question

我需要跨多个列格式化大量数据。 我有2列的数据需要格式化为一组2列，除了需要在数据左侧的单元格中的标题。

所以我需要将两列中的数据转换为：

header1 header2 data1 data2

因此需要将标题一直复制并粘贴到列中，并且需要追加多个列和标题。

这需要遍历整个电子表格。

以下是我的尝试

colA = 5
colB = 3
colC = 2
rowA = 3
rowB = 3
cellA = "C1"
Worksheets("sheet3").Activate
lastA = Cells(Rows.Count, colB).End(xlUp).Row
For x = rowA To lastA
    Worksheets("sheet3").Activate
    Data = Cells(x, colA)
    Worksheets("sheet3").Activate
    Cells(rowB, colB) = Data
    rowB = rowB + 1
Next x
Do Until colC = 0
Selection.Cut
Cells(1, colB).Select
ActiveSheet.Paste
Range("D1").Select
Selection.AutoFill Destination:=Cells(3, colC)
colC = colB - 1

Answer 1

不同的方法。

将源数据读入数组。 设置一个由每个结果行的数据组成的类 遍历源数组，一次两列，构造每一行。 将RowData存储到集合中。 完成后，将集合转移到“结果”数组中。 将结果数组写入Range（我选择在不同的工作表上执行此操作）。根据需要编辑源和目标范围。

首先插入一个类模块;将其重命名为 RowData ，然后粘贴以下代码：

Option Explicit
Private pHeaderOdd As String
Private pHeaderEven As String
Private pDataOdd As String
Private pDataEven As String

Public Property Get HeaderOdd() As String
    HeaderOdd = pHeaderOdd
End Property
Public Property Let HeaderOdd(Value As String)
    pHeaderOdd = Value
End Property

Public Property Get HeaderEven() As String
    HeaderEven = pHeaderEven
End Property
Public Property Let HeaderEven(Value As String)
    pHeaderEven = Value
End Property

Public Property Get DataOdd() As String
    DataOdd = pDataOdd
End Property
Public Property Let DataOdd(Value As String)
    pDataOdd = Value
End Property

Public Property Get DataEven() As String
    DataEven = pDataEven
End Property
Public Property Let DataEven(Value As String)
    pDataEven = Value
End Property

然后，在常规模块中，粘贴以下代码：

Sub ReFormat()
    Dim V As Variant, vRes() As Variant
    Dim cRD As RowData
    Dim colRD As Collection

    Dim I As Long, J As Long

'Get entire source data into array
'May need a different selection method
'  depending on your "real" data arrangement

V = Worksheets("Sheet4").Range("a1").CurrentRegion

'initialize collection
Set colRD = New Collection

'get data in pairs and add to collection
For I = 1 To UBound(V, 2) Step 2 'columns
    For J = 2 To UBound(V, 1) 'rows
        Set cRD = New RowData
            cRD.HeaderOdd = V(1, I)
            cRD.HeaderEven = V(1, I + 1)
            cRD.DataOdd = V(J, I)
            cRD.DataEven = V(J, I + 1)
        colRD.Add cRD
    Next J
Next I

'Put collection into "results" array for writing to the results range    
ReDim vRes(1 To colRD.Count, 1 To 4)
For I = 1 To colRD.Count
    vRes(I, 1) = colRD(I).HeaderOdd
    vRes(I, 2) = colRD(I).HeaderEven
    vRes(I, 3) = colRD(I).DataOdd
    vRes(I, 4) = colRD(I).DataEven
Next I

Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet2").Range("A1").Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes

End Sub

确保您的工作表和范围引用正确无误，然后运行宏。