为了账号安全,请及时绑定邮箱和手机立即绑定

使用VBA在Excel中融化/重塑?

/ 猿问

使用VBA在Excel中融化/重塑?

吃鸡游戏 2019-12-02 11:06:23

我目前正在适应新工作,我与同事共享的大部分工作都是通过MS Excel。我经常使用数据透视表,因此需要“堆叠的”数据,恰恰是我依赖R melt()的reshape(reshape2)包中函数的输出。


谁能让我开始使用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

查看完整描述

3 回答

?
凤凰求蛊

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


http://yoursumbuddy.com/data-normalizer


http://yoursumbuddy.com/data-normalizer-the-sql/


这是代码:


'Arguments

'List: The range to be normalized.

'RepeatingColsCount: The number of columns, starting with the leftmost,

'   whose headings remain the same.

'NormalizedColHeader: The column header for the rolled-up category.

'DataColHeader: The column header for the normalized data.

'NewWorkbook: Put the sheet with the data in a new workbook?

'

'NOTE: The data must be in a contiguous range and the

'columns that will be repeated must be to the left,

'with the columns to be normalized to the right.


Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _

    NormalizedColHeader As String, DataColHeader As String, _

    Optional NewWorkbook As Boolean = False)


Dim FirstNormalizingCol As Long, NormalizingColsCount As Long

Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range

Dim NormalizedRowsCount As Long

Dim RepeatingList() As String

Dim NormalizedList() As Variant

Dim ListIndex As Long, i As Long, j As Long

Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook

Dim wsTarget As Excel.Worksheet


With List

    'If the normalized list won't fit, you must quit.

   If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then

        MsgBox "The normalized list will be too many rows.", _

               vbExclamation + vbOKOnly, "Sorry"

        Exit Sub

    End If


    'You have the range to be normalized and the count of leftmost rows to be repeated.

   'This section uses those arguments to set the two ranges to parse

   'and the two corresponding arrays to fill

   FirstNormalizingCol = RepeatingColsCount + 1

    NormalizingColsCount = .Columns.Count - RepeatingColsCount

    Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)

    Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)

    NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count

    ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)

    ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)

End With


'Fill in every i elements of the repeating array with the repeating row labels.

For i = 1 To NormalizedRowsCount Step NormalizingColsCount

    ListIndex = ListIndex + 1

    For j = 1 To RepeatingColsCount

        RepeatingList(i, j) = List.Cells(ListIndex, j).Value2

    Next j

Next i


'We stepped over most rows above, so fill in other repeating array elements.

For i = 1 To NormalizedRowsCount

    For j = 1 To RepeatingColsCount

        If RepeatingList(i, j) = "" Then

            RepeatingList(i, j) = RepeatingList(i - 1, j)

        End If

    Next j

Next i


'Fill in each element of the first dimension of the normalizing array

'with the former column header (which is now another row label) and the data.

With ColsToNormalize

    For i = 1 To .Rows.Count

        For j = 1 To .Columns.Count

            NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)

            NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)

        Next j

    Next i

End With


'Put the normal data in the same workbook, or a new one.

If NewWorkbook Then

    Set wbTarget = Workbooks.Add

    Set wsTarget = wbTarget.Worksheets(1)

Else

    Set wbSource = List.Parent.Parent

    With wbSource.Worksheets

        Set wsTarget = .Add(after:=.Item(.Count))

    End With

End If


With wsTarget

    'Put the data from the two arrays in the new worksheet.

   .Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList

    .Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList


    'At this point there will be repeated header rows, so delete all but one.

   .Range("1:" & NormalizingColsCount - 1).EntireRow.Delete


    'Add the headers for the new label column and the data column.

   .Cells(1, FirstNormalizingCol).Value = NormalizedColHeader

    .Cells(1, FirstNormalizingCol + 1).Value = DataColHeader

End With

End Sub

您可以这样称呼它:


Sub TestIt()

NormalizeList ActiveSheet.UsedRange, 4, "Variable", "Value", False

End Sub


查看完整回答
反对 2019-12-02
?
三国纷争

Microsoft最近推出了Power Query,这是一个Excel加载项,它为Excel内的数据操作添加了许多有趣的功能,包括您要查找的内容。

内外接的实际功能被称为“逆透视列”,这是解释在这篇文章中。这是要点:

  1. 下载并安装加载项

  2. 打开您的Excel / CSV文件

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

  4. 在“高级查询”选项卡中,单击“从表”,这将打开“查询编辑器”

  5. 选择您要熔化/重塑的列(按Ctrl或Shift-Select,不要拖动)

  6. 在“转换”选项卡中,单击“取消透视列”(您还可以在此处应用其他转换,然后再返回Excel)

  7. 在“主页”选项卡中,单击“关闭并加载”。这将在Excel中创建具有所需结果的新表/查询对象。


查看完整回答
反对 2019-12-02
?
喵喵时光机

首先创建一个用户窗体,并将其命名为Unpivot_Form,其中包含两个RefEdit字段-rng_id和value_id以及一个提交/执行按钮。我也是R用户,rng_id是包含id的范围,而value_id包含值;两个范围都包括标题。


做两个宏:


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

请享用!


查看完整回答
反对 2019-12-02
  • 3 回答
  • 0 关注
  • 165 浏览

添加回答

回复

举报

0/150
提交
取消
意见反馈 帮助中心 APP下载
官方微信