宏可根据以下各列中的日期数来复制一系列单元格

Question

我有一个电子表格，必须将其转换为非常特殊的格式的会计团队。它是为我这一边使用而设置的。一个例子是这样的：

example spreadsheet

有两个以上的站点，它们都生产数量不定的产品。月数也发生变化。我基本上希望它采用长格式，以便每个站点上的每个产品都是其自己的行，并在该行上带有日期。

我在想，最好的开始方法是复制A和B列中的单元格范围，然后根据月份数将它们粘贴X次以下，然后根据以下内容将其剪切和粘贴下来产品和网站的数量。

我希望它看起来像这样。

output

我将非常感谢您的帮助！

干杯！

Answer 1

是的。

您需要自己设置3个变量：

• 设置数据表的最后一列编号，从左开始计数（I列= 9）
• 设置数据表的第一列编号，从左开始计数（B列= 2）
• 数据表标题（站点名称，产品等）的起始行号。

我建议不要合并单元格！

VBA代码：

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

结果将是：（您可以在下面看到我的示例设置）