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

-1

我有一个EXCEL数据集，需要使用数据集本身的值转换为更精简的格式。Excel VBA - 基于另一个表中的数据值创建新的Excel工作表

的原始数据集是这样的：

省份，城市，体育类，子类别，2011年1月，2011年2月，2011

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月，2月和1三月

结果应该是这样的：

省份，城市，体育类，类别，日期

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脚本吗？

谢谢。

来源

2014-10-08 RandiG

我确定有人会，但这不是真正的地方... – 2014-10-08 04:56:40

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

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

enter image description here