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