Question

我有一个自动生成的报告，可生成需要迭代并保存为其他格式的值表。

这是表格：

John Smith      5/26/2018   12345   IT Pro     John Gault   Permitting  Sarasota
Winston Smith   5/30/2018   54321   Henchman   Bob          Licensing   Oceania

我希望获取该信息的格式如下：

Name:   John Smith
Date Starting:  5/26/2018
Employee ID#:   12345
Title:  IT PRO
Supervisor: John Gault
Bus Ctr:    Permitting
Location:   Oceania

Name:   Winston Smith
Date Starting:  5/30/2018
Employee ID#:   54321
Title:  Henchman
Supervisor: Bob
Bus Ctr:    Licensing
Location:   Oceania

报告中的员工数量会在给定的一天发生变化，所以我相信For Each是有序的，有效的：

For Each Cell In ActiveSheet.UsedRange.Cells

我只是不确定将什么放入For循环中。

Answer 1

你可以用Excel的Get＆amp; amp;转换功能。首先 - 这是手动步骤：

使用列名
选择表格，然后按 Ctrl + T 创建表格
在数据标签上，点击从表格
在弹出的新编辑器中，选择所有列
在“转换”标签上，单击“Unpivot”
保存并退出

这不像宏一样直接，但Get＆amp;在这种情况下，变换非常强大。

Answer 2

你可以试试这段代码吗？我想你的数据是一张“数据”。

Sub test()
Application.DisplayAlerts = False

Dim sh_final As String
sh_final = "final"

Dim sh_data As String
sh_data = "data" 'change if different

Dim sh_template As String
sh_template = "template"


'create sheet template
Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name = sh_template Then
    ws.Delete
    End If
Next ws

 With ThisWorkbook
     .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sh_template
 End With
With ThisWorkbook.Sheets(sh_template)
     .Range("A1").Value = "Name :"
     .Range("A2").Value = "Date Starting:"
     .Range("A3").Value = "Employee ID#:"
     .Range("A4").Value = "Title :"
     .Range("A5").Value = "Supervisor:"
     .Range("A6").Value = "Bus Ctr:"
     .Range("A7").Value = "Location:"
 End With

'create sheet final
For Each ws In Worksheets
    If ws.Name = sh_final Then
    ws.Delete
    End If
Next ws
 With ThisWorkbook
     .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sh_final
 End With

'Copy data from sheet data
    For i = 1 To ThisWorkbook.Sheets(sh_data).Range("A" & ThisWorkbook.Sheets(sh_data).Rows.Count).End(xlUp).Row

    LastRow = ThisWorkbook.Sheets(sh_final).Range("A" & ThisWorkbook.Sheets(sh_final).Rows.Count).End(xlUp).Row + 1

    'Copy the template
    With ThisWorkbook.Sheets(sh_template)
    .Activate
    .Range("A1:A7").Copy
    End With

    With ThisWorkbook.Sheets(sh_final)
    .Activate
    .Range("A" & LastRow).Select
    End With
    ActiveSheet.Paste

    'copy the data
    With ThisWorkbook.Sheets(sh_data)
        .Activate
        .Range("A" & i & ":G" & i).Copy
    End With

    With ThisWorkbook.Sheets(sh_final)
        .Activate
        .Range("B" & LastRow).Select
    End With
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Next i


Application.DisplayAlerts = True

End Sub

Answer 3

通过转置数据字段数组接近

通过转置数据字段数组获取数据（行和列已更改），重新排列数组结构一次反向循环（在相同的数组）并将数组写回目标表：

代码示例

此代码示例假设您的数据表中的行1:1中有标题行：

Option Explicit                                      ' declaration head of your code module

Sub Iterate()
  Dim i As Long, j As Long, n As Long
  Dim nCol As Long, sCol As String
  Dim v                                               ' short for Dim v As Variant
  Dim ws As Worksheet, ws2 As Worksheet

  Set ws = ThisWorkbook.Worksheets("MyData")          ' << change to data sheet name
  Set ws2 = ThisWorkbook.Worksheets("MyTarget")       ' << change to target sheet name
' [1] get last row in column A containing data
   n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' [2] count header columns A:G (=7) and add one column to receive free line
   nCol = 7 + 1          ' nCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
' [3] get column letter after multiplication of rows with nCol
   sCol = Split(Cells(1, (n - 1) * nCol).Address, "$")(1)
' [4] get values to transposed one based 2dim array
   v = Application.Transpose(ws.Range("A1:" & sCol & n).Value)
' [5] rearrange data by reverse loop
  For i = n To 2 Step -1
     For j = 1 To nCol
       ' assign header (col 1) and data (col 2) to array items
         v((i - 2) * nCol + j, 1) = v(j, 1)  ' header
         v((i - 2) * nCol + j, 2) = v(j, i)  ' data
     Next j
  Next i
' [6] write back to target sheet
  ws2.Range("A:B") = ""                         ' clear columns A:B in target sheet
  ReDim Preserve v(1 To UBound(v), 2)           ' redim array to 2 columns
  ws2.Range("A1").Resize(UBound(v), 2) = v      ' write back
End Sub

备注

通常，（尚未转置的）数据字段数组将包含n个数据行和nCol列。由于此示例尝试重用原始数组，因此数据范围会更大，以包括所有项目乘以8 （即7列加空值）。

由于数据范围将被转置，列将更改为行。

由于总行必须包含产品行（n-1，即没有标题行）* 8，因此需要定义更大的列范围以接收更大的数组以便以后重新排列 - 请参阅第[3]节的定义专栏信。

数组项v((i - 2) * nCol + j, 2 )仅重新排列 2 列中的数据项，以便稍后将其写回目标工作表列{{ 1}}。考虑标题行（-1）以及从零开始（-1），新行索引B - 2 ((i必须计算) * nCol + j ，乘以i-2加上列nCol。

在VBA中迭代，保存和格式化单元格

3 个答案: