Макрос для копирования диапазона ячеек на основе количества дат в следующих столбцах - PullRequest
Новая
       19

Макрос для копирования диапазона ячеек на основе количества дат в следующих столбцах

0 голосов
/ 20 сентября 2018

У меня есть электронная таблица, которую я должен превратить в свою бухгалтерию в очень специфическом формате.Это ужасно для моей стороны бизнеса.Пример подобен следующему:

пример электронной таблицы

Существует более 2 сайтов, и все они производят различное количество продуктов.Количество месяцев также меняется.Я в основном хочу, чтобы это было в длинном формате, чтобы у каждого продукта на каждом сайте была своя собственная строка с датой в этой строке.

Я подумал, что лучший способ начать - скопировать диапазон ячеек в столбцах A и B и вставить их X количество раз ниже на основе количества месяцев, а затем вырезать и вставлять значения вниз иболее на основе количества продуктов и сайтов.

Я бы хотел, чтобы это выглядело так.

вывод

Буду очень признателен за помощь!

Ура!

1 Ответ

0 голосов
/ 21 октября 2018

Да, это возможно.

Вам нужно самостоятельно установить 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

Результат будет: (Вы можете увидеть мой пример настройки ниже)

enter image description here

...