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

这应该可行（它很快且很脏，如果设置与您的问题中描述的完全不同，则不一定可用） - 您需要用实际工作表名称替换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

Answer 3

好吧，看起来这些其他好人都打败了我，但这是我的版本：

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

重新格式化excel布局

3 个答案: