derretir/remodelar en excel usando VBA?

Question

Actualmente me estoy adaptando a un nuevo trabajo donde la mayor parte del trabajo que comparto con mis colegas es a través de MS Excel. Estoy usando tablas dinámicas con frecuencia, y por lo tanto necesito datos "apilados", precisamente el resultado de la función melt() en el paquete reshape (reshape2) en R que he llegado a confiar para esto.

¿Alguien podría iniciarme en una macro de VBA para lograr esto, o ya existe?

El contorno de la macro sería:

1. seleccionar un rango de celdas en un libro de Excel.
2. Comience macro "derretimiento".
3. Macro crearía un aviso, "Ingrese el número de columnas de id.", Donde ingresaría el número de columnas precedentes de información de identificación. (para el ejemplo del código R a continuación, es 4).
4. Cree una nueva hoja de trabajo en el archivo de Excel titulada "fundir" que apilaría los datos, y crearía una nueva columna titulada "variable" igual a los encabezados de columna de datos de la selección original.

En otras palabras, la salida sería exactamente la misma que la salida de limitarse a la ejecución de estas dos líneas en I:

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

He aquí un ejemplo:

# 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 

Answer 1

tengo Obtuve dos publicaciones, con código utilizable y libro descargable, al hacer esto en Excel/VBA en mi blog:

http://yoursumbuddy.com/data-normalizer

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

Aquí está el código:

'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 

que se podría llamar así:

Sub TestIt() 
NormalizeList ActiveSheet.UsedRange, 4, "Variable", "Value", False 
End Sub 

Answer 2

Para aquellos que buscan una forma visual para normalizar los datos de Excel, vea el vídeo tutorial:

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

Answer 3

Microsoft lanzó recientemente Power Query, un complemento de Excel que agrega muchas funciones y capacidades interesantes para la manipulación de datos desde Excel, incluido lo que está buscando.

La función real en el complemento se denomina "Columnas de no saliente", que se explica in this article.Aquí está el quid de la cuestión:

1. Download and install the add-in
2. Abran su archivo de Excel/CSV
3. seleccione la tabla/rango que desea fundir/remodelar
4. En la pestaña "Power consulta", haga clic en "De la tabla", que abrirá el "Editor de consultas"
5. Seleccione las columnas que desea fundir/remodelar (ctrl o shift-select, no arrastre)
6. En la pestaña "Transformar", haga clic en "Unpivot" Columnas "(también puede aplicar otras transformaciones aquí antes de regresar a Excel)
7. En la pestaña "Inicio", haga clic en "Cerrar & Cargar". Esto creará una nueva tabla/objeto de consulta en Excel con el resultado deseado.

Answer 4

o uso:

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 

Answer 5

En primer lugar crear un formulario de usuario y el nombre de Unpivot_Form con dos campos EDITREF - rng_id y value_id y un botón de envío/ir. También soy un usuario R y rng_id es el rango que contiene el ID, mientras que valor_id contiene el valor; ambos incluyen el encabezado

hacer dos macro:

Sub unpivot() 
Unpivot_Form.Show 
End Sub 

otra macro está dentro del botón de envío/ir del campo:

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 

disfrutar!