如何使用VBA在Excel中将单个列转置为多个不均匀的列/行

Question

我有不同的测试日期和时间，每个时间点最多可以进行约100次测试。 我收到的数据只有一个包含数千行的单列，这些数据应该已经以矩阵类型的网格进行了传递。

我只复制了一个样本，该样本具有6个时间点，每个样本最多4个测试。 当单元格中只有日期/时间时，我需要Excel“识别”，然后将该单元格复制到下一个日期/时间，以粘贴到新的工作表和列中。

最终，我希望将测试的标题与结果分开。 但是，如果在不知道每个测试名称的情况下这是不合理的，则可以跳过它。 这是我开始的数据：

Title

01/02/2010 0:03
Ounces: 10.87
Concentration: 6.89 (L)
Expiration Date: 11/2/2019  5:47:00

01/06/2011 2:06
Ounces: 18.09
Concentration: 10.7 (H)
Expiration Date: 11/2/2019  5:47:00
Other: Resampled

01/06/2011 2:06
Ounces: 12.87
Concentration: 10.9 (H)
Expiration Date: 11/2/2019  5:47:00
Other: 2nd Sample

09/15/2012 7:07
Ounces: 8.53
Concentration: 9.72
Expiration Date: 12/5/2019  4:45:00

05/02/2013 15:52
Ounces: 11.62
Concentration: 8.42

05/09/2017 1:45
Ounces: 9.34
Concentration: 8.98

我创建了以下Excel VBA，但在编程上还是一个新手，尤其是循环内的循环，因此我无法弄清楚如何创建足够动态以选择正确的单元格的偏移量，而是将其复制到新列中。 我在代码中也有冗余。

Sub Transpose()

    Dim dDate As Date
    Dim NumberofTasks As Long
    Dim x As Long

    sSheet = ActiveSheet.Name
    Sheets.Add
    dSheet = ActiveSheet.Name

    With Worksheets("Sheet1")
        ' All Data is in Column A
        NumberofTasks = .Cells(.Rows.Count, "A").End(xlUp).Row

        For x = 1 To NumberofTasks
            Sheets(sSheet).Activate
            If IsDate(.Range("A" & x).Value) Then '<-- check if current cell at Column A is Date
                Range(Cells(x, 1), Cells(x, 1).Offset(4, 0)).Select
                Selection.Copy
                Sheets(dSheet).Activate
                Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
                , Transpose:=True
                ActiveCell.Offset(1, 0).Select
            End If
        Next x

    End With

End Sub

这是我希望会发生的事情（但规模更大）：

但是，偏移量将另一个日期和当前代码放置在另一个单元格中。 感谢您能为我提供的任何帮助。

Answer 1

有很多方法可以给猫皮。 这是使用数组的一种方法，它比遍历范围快得多

工作表：

我为进行编码，假设数据位于Sheet1 ，如下所示

逻辑：

1. 将工作表中的数据存储在数组中； 我们称之为InputArray
2. 创建一个用于存储数据的输出数组； 我们称之为OutputArray
3. 遍历InputArray并找到日期，然后找到其余记录。 存储在OutputArray
4. 将输出从OutputArray到相关的工作表。

码：

Option Explicit

Sub Sample()
    Dim InputArray As Variant
    Dim ws As Worksheet
    Dim i As Long
    Dim recCount As Long
    Dim lRow As Long
    Dim OutputArray() As String

    '~~> Set relevant input sheet
    Set ws = Sheet1

    With ws
        '~~> Find Last Row in Col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Store col A in array
        InputArray = .Range("A1:A" & lRow).Value

        '~~> Find Total number of records
        For i = LBound(InputArray) To UBound(InputArray)
            If IsDate(InputArray(i, 1)) Then recCount = recCount + 1
        Next i

        '~~> Create an array for output
        ReDim OutputArray(1 To 5, 1 To recCount + 1)

        recCount = 2

        '~~> Fill Col A of output array
        OutputArray(1, 1) = "Title"
        OutputArray(2, 1) = "Ounces"
        OutputArray(3, 1) = "Concentration"
        OutputArray(4, 1) = "Expiration Date"
        OutputArray(5, 1) = "Other"

        '~~> Loop through input array
        For i = UBound(InputArray) To LBound(InputArray) Step -1
            If IsDate(InputArray(i, 1)) Then '< Check if date
                OutputArray(1, recCount) = InputArray(i, 1)

                '~~> Check for Ounces and store in array
                If i + 1 < UBound(InputArray) + 1 Then _
                If UCase(Left(Trim(InputArray(i + 1, 1)), 2)) = "OU" _
                Then OutputArray(2, recCount) = Trim(Replace(InputArray(i + 1, 1), "Ounces:", ""))

                '~~> Check for Concentration and store in array
                If i + 2 < UBound(InputArray) + 1 Then _
                If UCase(Left(Trim(InputArray(i + 2, 1)), 2)) = "CO" _
                Then OutputArray(3, recCount) = Trim(Replace(InputArray(i + 2, 1), "Concentration:", ""))

                '~~> Check for Expiration Date and store in array
                If i + 3 < UBound(InputArray) + 1 Then _
                If UCase(Left(Trim(InputArray(i + 3, 1)), 2)) = "EX" _
                Then OutputArray(4, recCount) = Trim(Replace(InputArray(i + 3, 1), "Expiration Date:", ""))

                '~~> Check for Other and store in array
                If i + 4 < UBound(InputArray) + 1 Then _
                If UCase(Left(Trim(InputArray(i + 4, 1)), 2)) = "OT" _
                Then OutputArray(5, recCount) = Trim(Replace(InputArray(i + 4, 1), "Other:", ""))

                recCount = recCount + 1
            End If
        Next i
    End With

    '~~> Output it to relevant sheet
    Sheet2.Range("A1").Resize(5, recCount - 1).Value = OutputArray
End Sub

输出：

Answer 2

可以尝试这样的事情。 原始代码已被修改和组织以完成预期的任务。 小心测试结果的其他参数是否没有按所示顺序排列，参数之间没有空白行，测试结果之间没有空白行，或者缺少参数。 它仅考虑在两个测试标题的行之间找到的参数（日期时间）。 仅需0.5秒即可处理超过1 K行的200个测试结果。

Option Explicit
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long, LastRow As Long, Xval As Variant
Dim srcWs As Worksheet, trgWs As Worksheet
Dim tm As Double
tm = Timer
Set srcWs = ThisWorkbook.ActiveSheet
Set trgWs = ThisWorkbook.Worksheets.Add
trgWs.Cells(1, 1).Value = "Title"
trgWs.Cells(2, 1).Value = "Ounces:"
trgWs.Cells(3, 1).Value = "Concentration:"
trgWs.Cells(4, 1).Value = "Expiration Date:"
trgWs.Cells(5, 1).Value = "Other:"

With srcWs
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    NumberofTasks = 0
    x = 1
    Do While x <= LastRow
    Xval = .Cells(x, 1).Value
        If IsDate(Xval) Then
        NumberofTasks = NumberofTasks + 1
        trgWs.Cells(1, NumberofTasks + 1).Value = .Range("A" & x).Value
        ElseIf VarType(Xval) = vbString And NumberofTasks > 0 Then
        Xval = Trim(LCase(Xval))
           If InStr(1, Xval, "ounces:") > 0 Then
           trgWs.Cells(2, NumberofTasks + 1).Value = Trim(Replace(Xval, "ounces:", ""))
           ElseIf InStr(1, Xval, "concentration:") > 0 Then
           trgWs.Cells(3, NumberofTasks + 1).Value = Trim(Replace(Xval, "concentration:", ""))
           ElseIf InStr(1, Xval, "expiration date:")  > 0 Then
           trgWs.Cells(4, NumberofTasks + 1).Value = Trim(Replace(Xval, "expiration date:", ""))
           ElseIf InStr(1, Xval, "other:")  > 0 Then
           trgWs.Cells(5, NumberofTasks + 1).Value = Trim(Replace(Xval, "other:", ""))
           End If
        End If
    x = x + 1
    Loop
End With
'Debug.Print "Seconds "; Timer - tm
End Sub

经测试产生类似的结果这

Answer 3

我认为这是使用Range.Find更好方法

• 假设数据在Sheet1第一列，即 A栏
• 在演示中，到期日期不正确，我已在代码中更正了该日期。

试试这个代码：

Sub TP()

Dim wk As Worksheet: Set wk = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long: lr = wk.Cells(wk.Rows.Count, "A").End(xlUp).row

Dim rng As Range
Dim i As Long
Dim j As Long
j = 4
For i = 3 To lr

    Set rng = wk.Range(Cells(i, 1), Cells(i, 1).End(xlDown))
        wk.Cells(2, j).Value = rng.Cells(1, 1).Value

    Set fnd = rng.Find("Ounces")
        If Not fnd Is Nothing Then wk.Cells(3, j).Value = Split(fnd.Value, ":")(1)
        Set fnd = Nothing
    Set fnd = rng.Find("Concentration")
        If Not fnd Is Nothing Then wk.Cells(4, j).Value = Split(fnd.Value, ":")(1)
        Set fnd = Nothing
    Set fnd = rng.Find("Expiration")
        If Not fnd Is Nothing Then wk.Cells(5, j).Value = Right(fnd.Value, Len(fnd.Value) - Len(Split(fnd.Value, ":")(0)) - 2)
        Set fnd = Nothing
    Set fnd = rng.Find("Other")
        If Not fnd Is Nothing Then wk.Cells(6, j).Value = Split(fnd.Value, ":")(1)
        Set fnd = Nothing

    i = Cells(i, 1).End(xlDown).row + 1
    j = j + 1
Next

End Sub

---

演示：