如何使用 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

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

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

经过测试以产生类似的结果 this

Answer 2

我认为这是使用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

---

演示：

Answer 3

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

工作表：

我是为了编码，假设数据在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

输出：