Excel VBA - 基于另一个工作表中的数据值创建新的Excel工作表

Question

我有一个EXCEL数据集，我需要使用数据集本身的值转换为更精简的格式。

原始数据集如下所示：

州，城市，体育类别，子类别，2011年1月，2011年2月，2011年3月

NSW,Paramatta,Field,Cricket,3,2,1
NSW,Paramatta,Field,Soccor,2,2,2
VIC,Bundoora,Indoor,Table Tennic,1,3,2
VIC,Bundoora,Indoor,Swimming,1,2,2

每行（前四个字段）必须重复，具体取决于日期字段下的实例数。新字段的值应为发生日期。例如，上面的第一个条目应该变为6个条目，其中3个用于1月，2个用于2月，1个用于3月。

结果应如下所示：

州，城市，体育类别，子类别，日期

NSW,Paramatta,Field,Cricket,Jan-11
NSW,Paramatta,Field,Cricket,Jan-11
NSW,Paramatta,Field,Cricket,Jan-11
NSW,Paramatta,Field,Cricket,Feb-11
NSW,Paramatta,Field,Cricket,Feb-11
NSW,Paramatta,Field,Cricket,Mar-11
NSW,Paramatta,Field,Soccor,Jan-11
NSW,Paramatta,Field,Soccor,Jan-11
NSW,Paramatta,Field,Soccor,Feb-11
NSW,Paramatta,Field,Soccor,Feb-11
NSW,Paramatta,Field,Soccor,Mar-11
VIC,Bundoora,Indoor,Table Tennic,Jan-11
VIC,Bundoora,Indoor,Table Tennic,Feb-11
VIC,Bundoora,Indoor,Table Tennic,Feb-11
VIC,Bundoora,Indoor,Table Tennic,Feb-11
VIC,Bundoora,Indoor,Table Tennic,Mar-11
VIC,Bundoora,Indoor,Table Tennic,Mar-11
VIC,Bundoora,Indoor,Swimming,Jan-11
VIC,Bundoora,Indoor,Swimming,Feb-11
VIC,Bundoora,Indoor,Swimming,Feb-11
VIC,Bundoora,Indoor,Swimming,Mar-11
VIC,Bundoora,Indoor,Swimming,Mar-11

有人能够为此组合一个VBA脚本吗？

感谢。

Answer 1

你需要UNPIVOT，Excel可以原生这样做。 http://office.microsoft.com/en-au/excel-help/unpivot-columns-HA104053356.aspx

Answer 2

Sub mcr_Expand_Match_Data()
    Dim lc As Long, lr As Long, rw As Long, d As Long, m As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Sheet7")  'source worksheet
    Set ws2 = Sheets("Sheet8")  'target worksheet
    With ws2
        .Cells(1, 1).CurrentRegion.ClearContents
        .Cells(1, 1).Resize(1, 5) = Array("State", "City", "Sports category", "Subcategory", "Date")
    End With
    With ws1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        For rw = 2 To lr
            For d = 5 To lc
                For m = 1 To .Cells(rw, d).Value
                    ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 4) = _
                      .Cells(rw, 1).Resize(1, 4).Value
                    ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 4) = _
                      .Cells(1, d).Value
                Next m
            Next d
        Next rw
    End With
    Set ws2 = Nothing
    Set ws1 = Nothing
End Sub

您需要更改第三行和第四行中的源和目标工作表名称。它应该能够在源工作表的右端添加额外的匹配数据列。这将产生如下所示的结果。