R 使用VBA在excel中熔化/重塑？

我目前正在适应一份新工作，我与同事分享的大部分工作都是通过MS Excel完成的。我经常使用pivot表，因此需要“堆叠”数据，即R中的

restrape

（restrape2）包中

melt（）

函数的输出

有人能让我开始使用VBA宏来完成这项工作吗，或者已经有了吗？

宏的概要将是：

在Excel工作簿中选择一系列单元格

启动“熔化”宏

宏将创建一个提示，“输入id列的数量”，在该提示中，您将输入标识信息的前几列的数量。（下面的示例R代码为4）

在excel文件中创建一个名为“melt”的新工作表 这将堆叠数据，并创建一个名为“variable”的新列 等于原始选择中的数据列标题

换句话说，输出看起来与在R中简单执行这两行的输出完全相同：

require(reshape)
melt(your.unstacked.dataframe, id.vars = 1:4)

下面是一个例子：

# unstacked data
> df1
  Year Month Country  Sport No_wins No_losses High_score Total_games
2 2010     5     USA Soccer       4         3          5           9
3 2010     6     USA Soccer       5         3          4           8
4 2010     5     CAN Soccer       2         9          7          11
5 2010     6     CAN Soccer       4         8          4          13
6 2009     5     USA Soccer       8         1          4           9
7 2009     6     USA Soccer       0         0          3           2
8 2009     5     CAN Soccer       2         0          6           3
9 2009     6     CAN Soccer       3         0          8           3

# stacking the data
> require(reshape)
> melt(df1, id.vars=1:4)

  Year Month Country  Sport    variable value
1  2010     5     USA Soccer     No_wins     4
2  2010     6     USA Soccer     No_wins     5
3  2010     5     CAN Soccer     No_wins     2
4  2010     6     CAN Soccer     No_wins     4
5  2009     5     USA Soccer     No_wins     8
6  2009     6     USA Soccer     No_wins     0
7  2009     5     CAN Soccer     No_wins     2
8  2009     6     CAN Soccer     No_wins     3
9  2010     5     USA Soccer   No_losses     3
10 2010     6     USA Soccer   No_losses     3
11 2010     5     CAN Soccer   No_losses     9
12 2010     6     CAN Soccer   No_losses     8
13 2009     5     USA Soccer   No_losses     1
14 2009     6     USA Soccer   No_losses     0
15 2009     5     CAN Soccer   No_losses     0
16 2009     6     CAN Soccer   No_losses     0
17 2010     5     USA Soccer  High_score     5
18 2010     6     USA Soccer  High_score     4
19 2010     5     CAN Soccer  High_score     7
20 2010     6     CAN Soccer  High_score     4
21 2009     5     USA Soccer  High_score     4
22 2009     6     USA Soccer  High_score     3
23 2009     5     CAN Soccer  High_score     6
24 2009     6     CAN Soccer  High_score     8
25 2010     5     USA Soccer Total_games     9
26 2010     6     USA Soccer Total_games     8
27 2010     5     CAN Soccer Total_games    11
28 2010     6     CAN Soccer Total_games    13
29 2009     5     USA Soccer Total_games     9
30 2009     6     USA Soccer Total_games     2
31 2009     5     CAN Soccer Total_games     3
32 2009     6     CAN Soccer Total_games     3

---

我的博客上有两篇关于在Excel/VBA中执行此操作的文章，其中包含可用代码和可下载的工作簿：

代码如下：

”参数
'列表：要规范化的范围。
'RepeatingColsCount:列数，从最左边开始，
“标题保持不变。
'NormalizedColHeader:汇总类别的列标题。
'DataColHeader:规范化数据的列标题。
'新建工作簿：是否将包含数据的工作表放在新工作簿中？
'
'注意：数据必须在连续范围内，并且
'将重复的列必须位于左侧，
'将列规格化到右侧。
子规范化列表（列表形式为Excel.Range，重复ColsCount的长度_
NormalizedColHeader作为字符串，DataColHeader作为字符串_
可选的新工作簿（布尔值=False）
将第一个规格化列变暗为长，规格化列变暗为长
将ColsToRepeat设置为Excel.Range，将ColsToRepeat设置为Excel.Range
变暗和变长一样长
Dim RepeatingList（）作为字符串
Dim NormalizedList（）作为变量
Dim ListIndex尽可能长，i尽可能长，j尽可能长
将wbSource设置为Excel.工作簿，wbTarget设置为Excel.工作簿
将wsTarget设置为Excel.工作表
带列表
'如果规范化列表不适合，您必须退出。
如果.Rows.Count*（.Columns.Count-repeatingcolscont）>.Parent.Rows.Count，则
MsgBox“规范化列表将有太多行。”_
V感叹号+V仅限“对不起”
出口接头
如果结束
'您有要规格化的范围和要重复的最左侧行的计数。
'本节使用这些参数设置要分析的两个范围
'和要填充的两个对应数组
FirstNormalizingCol=RepeatingColsCount+1
NormalizingColsCount=.Columns.Count-RepeatingColsCount
设置ColsToRepeat=.Cells（1）。调整大小（.Rows.Count，repeatingcolscont）
设置ColsToNormalize=.Cells（1，firstnormalizaingcol）.Resize（.Rows.Count，normalizationcolscont）
NormalizedRowsCount=ColsToNormalize.Columns.Count*.Rows.Count
ReDim RepeatingList（1到NormalizedRowsCount，1到RepeatingColsCount）
ReDim NormalizedList（1到NormalizedRowsCount，1到2）
以
'使用重复行标签填充重复数组的每个i元素。
对于i=1，以规范化rowscount步骤规范化ColsCount
ListIndex=ListIndex+1
对于j=1，重复ColsCount
RepeatingList（i，j）=List.Cells（ListIndex，j）.Value2
下一个j
接下来我
'我们跨过了上面的大多数行，所以填充其他重复的数组元素。
对于i=1，以使计数正常化
对于j=1，重复ColsCount
如果RepeatingList（i，j）=“那么
RepeatingList（i，j）=RepeatingList（i-1，j）
如果结束
下一个j
接下来我
'填充规范化数组第一个维度的每个元素
'和以前的列标题（现在是另一个行标签）以及数据。
使用ColsToNormalize
对于i=1到.Rows.Count
对于j=1到.Columns.Count
NormalizedList（（（i-1）*normalizedColsCount）+j，1）=单元格（1，j）
NormalizedList（（（i-1）*normalizedColsCount）+j，2）=单元格（i，j）
下一个j
接下来我
以
'将正常数据放在同一工作簿或新工作簿中。
如果是，那么
设置wbTarget=工作簿。添加
设置wsTarget=wbTarget.Worksheets（1）
其他的
设置wbSource=List.Parent.Parent
使用wbSource.Worksheets
设置wsTarget=.Add（后面：=.Item（.Count））
以
如果结束
有目标
'将两个数组中的数据放入新工作表中。
.Range（“A1”）.Resize（NormalizedRowsCount，RepeatingColsCount）=RepeatingList
.Cells（1，firstnormalingcol）.Resize（NormalizedRowsCount，2）=NormalizedList
'此时将有重复的标题行，因此删除除一行以外的所有行。
.Range（“1:&normalizationcolscont-1）.EntireRow.Delete
'添加新标签列和数据列的标题。
.Cells（1，FirstNormalingCol）.Value=NormalizedColHeader
.Cells（1，firstnormalingcol+1）。Value=DataColHeader
以
端接头

你可以这样称呼它：

子测试（）
NormalizeList ActiveSheet.UsedRange，4，“变量”，“值”，False
端接头

任何想要以可视化方式规范excel数据的人，请参阅本视频教程：

---

Microsoft最近推出了Power Query，这是一个Excel外接程序，它为Excel中的数据操作添加了许多有趣的功能和功能，包括您要查找的内容

外接程序中的实际函数称为“Unpivot Columns”，如下所述。以下是它的要点：

打开Excel/CSV文件

选择要熔化/重塑的表格/范围

在“电源查询”选项卡中，单击“来自表”，将打开“查询编辑器”

选择要熔化/重塑的柱（ctrl或shift-sele）

Sub M_snb_000()
  With sheet1.Cells(1).CurrentRegion
    sn = .Resize(, .Columns.Count + 1)
  End With

  For j = 4 To UBound(sn, 2) - 1
    With Sheet2.Cells(2 + (UBound(sn) - 1) * (j - 4), 1)
       .Resize(UBound(sn) - 1, 5) = Application.Index(sn, Evaluate("row(2:" 
             & UBound(sn) & ")"), Array(1, 2, 3,UBound(sn, 2), j))
       .Resize(UBound(sn) - 1, 1).Offset(, 3) = sn(1, j)
    End With
  Next
End Sub

Sub unpivot()
Unpivot_Form.Show
End Sub

Private Sub submit_Click()
'Code to unpivot (convert wide to long for excel)

Dim rng_id, rng_id_header, val_id As Range
Dim colvar, emptyrow, col As Integer
Dim new_sheet As Worksheet

'Put val_id range into a range object
Set val_id = Range(value_id.Value)

'Determine the parameter for the value id range
'This is used for the looping later on
numrows = val_id.Rows.Count
numcols = val_id.Columns.Count

'Resize changes the "block" to the size defined by the row and column
'Offset moves the "block"
Set rng_id_header = Range(range_id.Value).Resize(1)
Set rng_id = Range(range_id.Value).Offset(1, 0).Resize(numrows - 1)

Set new_sheet = Worksheets.Add

'Set up the first column and first batch of id vars
new_sheet.Activate
Range("A65535").End(xlUp).Activate
rng_id_header.Copy ActiveCell
colvar = Range("XFD1").End(xlToLeft).Column + 1
Range("XFD1").End(xlToLeft).Offset(, 1).Value = "Variable"
Range("XFD1").End(xlToLeft).Offset(, 1).Value = "Value"

'Start populating the value ids
For col = 1 To numcols

  'populate var_id
  'determine last row
   emptyrow = Range("A65535").End(xlUp).Row + 1
   'no need to activate to source to copy
   rng_id.Copy new_sheet.Cells(emptyrow, 1)
  'copy the variable
  val_id.Offset(, col - 1).Resize(1, 1).Copy new_sheet.Range(Cells(emptyrow, colvar), Cells(emptyrow + numrows - 2, colvar))
  'copy the value
  val_id.Offset(1, col - 1).Resize(numrows - 1, 1).Copy new_sheet.Range(Cells(emptyrow, colvar + 1), Cells(emptyrow + numrows - 2, colvar + 1))

Next

Unload Me

End Sub