Переформатирование макета Excel

Question

Я надеюсь, что смогу объяснить это достаточно хорошо.
У меня есть документ Excel, который был выложен как таковой;

     A      B      C      D     ...     n
1 [     ][  H  ][  H  ][  H  ][ ... ][  H  ]
2 [     ][  T  ][  T  ][  T  ][ ... ][  T  ]
3 [  C  ][  D  ][  D  ][  D  ][ ... ][  D  ]
4 [  C  ][  D  ][  D  ][  D  ][ ... ][  D  ]
5 [  C  ][  D  ][  D  ][  D  ][ ... ][  D  ]
. [ ... ][ ... ][ ... ][ ... ][ ... ][  D  ]
n [  C  ][  D  ][  D  ][  D  ][  D  ][  D  ]

H: Основной заголовок
T: Название
C: боковой заголовок
D: данные (некоторые также могут быть пустыми)

Мне нужно преобразовать это в формат, который может использоваться базой данных.Я знаю, во что я хочу преобразовать это, но я не знаю, как это сделать (с помощью vba или любой другой альтернативы).
То, что я хотел бы, это;

     A      B      C      D
1 [  C  ][  T  ][  H  ][  D  ]
2 [  C  ][  T  ][  H  ][  D  ]
3 [  C  ][  T  ][  H  ][  D  ]
. [ ... ][ ... ][ ... ][ ... ]
n [  C  ][  T  ][  H  ][  D  ]

Как я думаюможно было бы выполнить цикл по жизнеспособной области (все «данные», представленные как «D»), проверить, чтобы убедиться, что в нем содержатся данные (если не печатать эту строку), а затем получить соответствующие заголовкии распечатывать конечные продукты, перезаписывая предыдущие данные или помещая их на другой лист.

Спасибо!Любая помощь приветствуется.

Answer 1

вот полный рабочий код (по крайней мере, в моем примере):

Option Explicit

Sub convert_for_DB()
Dim lLastRow As Long, lLastCol As Long
Dim c As Range
Dim index As Long
Dim aH As Variant, aT As Variant, aC As Variant
Dim vValues() As Variant

With Worksheets("Sheet1")
    'find the last row and the last col
    lLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    'get the headers
    aH = .Range("B1", .Cells(1, lLastCol)).Value
    aT = .Range("B2", .Cells(2, lLastCol)).Value
    aC = .Range("A3", .Cells(lLastRow, 1)).Value
    'create an array with the number of values
    ReDim vValues((lLastRow - 2) * (lLastCol - 1), 3)

    index = 0
    'parse every value of the array
    For Each c In .Range("B3", .Cells(lLastRow, lLastCol))
        If Len(c.Value) > 0 Then
            vValues(index, 0) = aC(c.Row - 2, 1)
            vValues(index, 1) = aH(1, c.Column - 1)
            vValues(index, 2) = aT(1, c.Column - 1)
            vValues(index, 3) = c.Value
            index = index + 1
        End If
    Next c
End With

'store back the data to another sheet
With Worksheets("Sheet2")
    .Range("A1", .Cells(UBound(vValues, 1), 4)) = vValues
End With
End Sub

Answer 2

Ну, похоже, что эти другие замечательные люди избили меня до отказа, но вот моя версия:

Sub FormatData()
    Dim newRowCount
    Dim currentCell
    Dim startCell
    Dim numDataRows
    Dim numDataCols
    Dim i
    Dim j

    newRowCount = 0
    numDataRows = Sheet1.UsedRange.Rows.Count - 2
    numDataCols = Sheet1.UsedRange.Columns.Count - 1

    Set startCell = Sheet1.Cells(3, 2)

    For i = 0 To numDataRows - 1
        For j = 0 To numDataCols - 1
            Set currentCell = startCell.Offset(i, j)
            If startCell.Offset(i, j) <> "" Then
                newRowCount = newRowCount + 1
                Sheet2.Cells(newRowCount, 1).Value = Sheet1.Cells(currentCell.Row, 1).Value
                Sheet2.Cells(newRowCount, 2).Value = Sheet1.Cells(2, currentCell.Column).Value
                Sheet2.Cells(newRowCount, 3).Value = Sheet1.Cells(1, currentCell.Column).Value
                Sheet2.Cells(newRowCount, 4).Value = currentCell.Value
            End If
        Next j
    Next i
End Sub

Answer 3

Это должно работать (это быстро и грязно, поэтому не обязательно использовать, если настройка не совсем соответствует описанной в вашем вопросе) - вам нужно заменить Sheet1 и Sheet2 на настоящие имена листов.

Public Sub runMeOnce()

  Dim sourceSheet As String
  Dim destinationSheet As String
  Dim i As Long
  Dim j As Long
  Dim destinationRow As Long
  Dim originalData As Variant
  Dim destinationData As Variant

  sourceSheet = "Sheet1"
  destinationSheet = "Sheet2"

  originalData = Sheets(sourceSheet).UsedRange
  ReDim destinationData(1 To (UBound(originalData, 1) - 2) * (UBound(originalData, 2) - 1) + 1, 1 To 4) As Variant

  destinationData(1, 1) = "Side Header"
  destinationData(1, 2) = "Title"
  destinationData(1, 3) = "Header"
  destinationData(1, 4) = "Data"

  destinationRow = 2
  For i = 3 To UBound(originalData, 1)
    For j = 2 To UBound(originalData, 2)
      destinationData(destinationRow, 1) = originalData(i, 1)
      destinationData(destinationRow, 2) = originalData(2, j)
      destinationData(destinationRow, 3) = originalData(1, j)
      destinationData(destinationRow, 4) = originalData(i, j)
      destinationRow = destinationRow + 1
    Next j
  Next i

  Sheets(destinationSheet).Cells(1, 1).Resize(UBound(destinationData, 1), UBound(destinationData, 2)) = destinationData

End Sub