расплавить / переформовать в excel с помощью VBA?


В настоящее время я приспосабливаюсь к новой работе, где большая часть работы, которую я делю с коллегами, выполняется через MS Excel. Я часто использую сводные таблицы, и поэтому мне нужны "штабелированные" данные, именно выходные данные функции melt() в пакете reshape (reshape2) в R, на которые я привык полагаться для этого.

Может ли кто-нибудь заставить меня начать работу над макросом VBA, чтобы выполнить это, или он уже существует?

Контур макроса будет выглядеть следующим образом:

  1. выбор диапазона ячеек в книге Excel.
  2. начните "плавить" макрос.
  3. макрос создаст запрос "введите число столбцов идентификаторов", в котором вы введете число, предшествующее столбцам идентифицирующей информации. (для примера кода R ниже это 4).
  4. создайте новый лист в файле excel под названием " melt" это позволит сложить данные и создать новый столбец под названием "переменная" равно заголовкам столбцов данных из исходной выборки.

Другими словами, выходные данные будут выглядеть точно так же, как результат простого выполнения этих двух строк в 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
5 16

5 ответов:

У меня есть две записи, с полезным кодом и загружаемой книгой, о том, как это сделать в 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
'rows that will be repeated must be to the left,
'with the rows 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

Недавно Microsoft выпустила Power Query, надстройку Excel, которая добавляет много интересных функций и возможностей для обработки данных из Excel, включая то, что вы ищете.

Фактическая функция в надстройке называется "Unpivot Columns", что объясняетсяв этой статье . Вот в чем суть:

  1. Загрузите и установите надстройку
  2. Откройте файл Excel / CSV
  3. выберите таблицу/диапазон, который вы хотите расплавить / изменить форму
  4. во вкладке" Power Query "нажмите на кнопку "From Table", которая откроет "редактор запросов"
  5. выберите столбцы, которые вы хотите расплавить/изменить форму (ctrl или shift-выбрать, не перетаскивать)
  6. на вкладке" преобразование " нажмите на "Unpivot Columns" (вы также можете применить здесь другие преобразования перед возвращением в Excel)
  7. на вкладке" Главная "нажмите кнопку"Закрыть и загрузить". Это создаст новый объект таблицы / запроса в Excel с требуемым результатом.

Для тех, кто ищет визуальный способ нормализации данных excel, смотрите этот видеоурок:

Http://www.youtube.com/watch?v=xmqTN0X-AgY

Сначала создайте форму пользователя и назовите ее Unpivot_Form с двумя полями RefEdit-rng_id и value_id и кнопкой submit / go. Я также являюсь пользователем R, и rng_id-это диапазон, содержащий идентификатор, в то время как value_id содержит значение; оба диапазона включают заголовок.

Сделайте два макроса:

Sub unpivot()
Unpivot_Form.Show
End Sub

Другой макрос находится в кнопке submit / go поля:

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

Наслаждайтесь!

Или использовать:

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