问宏根据以下列中的日期数复制一系列单元格？

EN

Sub Transpoose_Data()
Dim Month As Date
Dim LastDateColumn As Long
Dim FirstColumnData As Long
Dim LastRowData As Long
Dim HeaderRow As Long
Dim DateColumn As Variant
Dim DateColumnD As Date
Dim i As Long

Dim HeaderNewMonth As String
Dim HeaderNewSiteName As String
Dim HeaderNewProduct As String
Dim HeaderNewQuality As String
Dim HeaderNewPrice As String

Dim HeaderNewMonthLastRow As Long
Dim HeaderNewSiteNameLastRow As Long
Dim HeaderNewProductLastRow As Long
Dim HeaderNewQualityLastRow As Long
Dim HeaderNewPriceLastRow As Long
Dim HeaderNewPriceLastRow2 As Long

'############### Set Data Values ###############

LastDateColumn = 9 'Set last column in dataset. Where Column 9 = Column I
FirstColumnData = 2 'Set first column in dataset. Where Column 2 = Column B
HeaderRow = 5 'Row Number where headers are located

'############### Set Data Values ###############

HeaderNewMonth = "Month"
HeaderNewSiteName = "Site Name"
HeaderNewProduct = "Product"
HeaderNewQuality = "Quality"
HeaderNewPrice = "Price"

'Find new cell destination for the new columns
Cells(HeaderRow, LastDateColumn + 2) = HeaderNewMonth
Cells(HeaderRow, LastDateColumn + 3) = HeaderNewSiteName
Cells(HeaderRow, LastDateColumn + 4) = HeaderNewProduct
Cells(HeaderRow, LastDateColumn + 5) = HeaderNewQuality
Cells(HeaderRow, LastDateColumn + 6) = HeaderNewPrice

'Last row for data sample to be copied
LastRowData = Cells(Rows.Count, FirstColumnData).End(xlUp).Row

For i = 2 To LastDateColumn 'Loop trough all date columns
    DateColumn = Cells(HeaderRow - 1, i).Value 'Get date value
    If Not DateColumn = "" Then 'If cell is not empty then
        DateColumnD = Cells(HeaderRow - 1, i).Value 'Take the cell value

        HeaderNewMonthLastRow = Cells(Rows.Count, LastDateColumn + 2).End(xlUp).Row 'Find last row for Column "Month" in the new table
        HeaderNewSiteNameLastRow = Cells(Rows.Count, LastDateColumn + 3).End(xlUp).Row 'Find last row for Column "SiteName" in the new table
        HeaderNewProductLastRow = Cells(Rows.Count, LastDateColumn + 4).End(xlUp).Row 'Find last row for Column "Product" in the new table
        HeaderNewQualityLastRow = Cells(Rows.Count, LastDateColumn + 5).End(xlUp).Row 'Find last row for Column "Quality" in the new table
        HeaderNewPriceLastRow = Cells(Rows.Count, LastDateColumn + 6).End(xlUp).Row 'Find last row for Column "Price" in the new table

        'Copy Date Values from the old table and paste into the new table
        Range(Cells(HeaderNewSiteNameLastRow + 1, LastDateColumn + 2), Cells(((HeaderNewSiteNameLastRow) + (LastRowData - HeaderRow)), LastDateColumn + 2)).Value = DateColumnD
        'Copy SiteName Values from the old table and paste into the new table
        Range(Cells(HeaderNewSiteNameLastRow + 1, LastDateColumn + 3), Cells(((HeaderNewSiteNameLastRow) + (LastRowData - HeaderRow)), LastDateColumn + 3)).Value = Range(Cells(HeaderRow + 1, FirstColumnData), Cells(LastRowData, FirstColumnData)).Value
        'Copy Product Values from the old table and paste into the new table
        Range(Cells(HeaderNewSiteNameLastRow + 1, LastDateColumn + 4), Cells(((HeaderNewSiteNameLastRow) + (LastRowData - HeaderRow)), LastDateColumn + 4)).Value = Range(Cells(HeaderRow + 1, FirstColumnData + 1), Cells(LastRowData, FirstColumnData + 1)).Value
        'Copy Quality Values from the old table and paste into the new table
        Range(Cells(HeaderNewSiteNameLastRow + 1, LastDateColumn + 5), Cells(((HeaderNewSiteNameLastRow) + (LastRowData - HeaderRow)), LastDateColumn + 5)).Value = Range(Cells(HeaderRow + 1, i), Cells(LastRowData, i)).Value
        'Copy Price Values from the old table and paste into the new table
        Range(Cells(HeaderNewSiteNameLastRow + 1, LastDateColumn + 6), Cells(((HeaderNewSiteNameLastRow) + (LastRowData - HeaderRow)), LastDateColumn + 6)).Value = Range(Cells(HeaderRow + 1, i + 1), Cells(LastRowData, i + 1)).Value

    End If

Next i

'Line border at header bottom for the new table
Range(Cells(HeaderRow, LastDateColumn + 2), Cells(HeaderRow, LastDateColumn + 6)).Borders(xlEdgeBottom).Color = RGB(0, 0, 0)

HeaderNewPriceLastRow2 = Cells(Rows.Count, LastDateColumn + 6).End(xlUp).Row
'Fix the format for the Date column
Range(Cells(HeaderRow, LastDateColumn + 2), Cells(HeaderNewPriceLastRow2, LastDateColumn + 2)).NumberFormat = "[$-409]MMM-yy;@"
'Fix the format for for the Price column
Range(Cells(HeaderRow, LastDateColumn + 6), Cells(HeaderNewPriceLastRow2, LastDateColumn + 6)).NumberFormat = "[$$-409]#,##0.00"
End Sub