使用宏对齐多行以适合Excel中的一行

Question

我有一些excel数据来自实验室的奇怪格式，我试图找出如何将所有患者数据放在同一行。下面是一个示例，其中一个条目以红色突出显示，因此您可以看到整个内容跨越3行：

我认为一个宏可以很好地用于这样的事情，但记录宏是我的知识范围。我真的不知道怎么写VBA。目标是将所有患者信息放在同一行，以便过滤它们（例如下面）：

我自己做了什么：当我意识到引用可能会根据工作表的标题发生变化时，我开始记录宏并手动更改内容（用于录制）。我可以做一个相对参考宏，但是然后将光标指向每个患者的正确位置一遍又一遍，这几乎和手工做的一样多。似乎应该有一种方式可以说“三行中包含的所有内容都是一个'条目'，所以放在一行，从这里开始到那里结束”还是什么？

Answer 1

这是怎么回事：

Sub text()
Dim lastRow As Integer, ageCol As Integer, addressCol As Integer, i As Integer, endRow As Integer
Dim startRow As Integer, phoneCol As Integer

lastRow = ActiveSheet.UsedRange.Rows.Count
ageCol = Rows(1).Find(what:="DOB_Age").Column
addressCol = Rows(1).Find(what:="Address").Column
phoneCol = Rows(1).Find(what:="Phone").Column

'Starting off, go to first name in the list.
startRow = Cells(1, 1).End(xlDown).Row
endRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

For i = startRow To endRow
    Cells(i, 1).Select
    If Cells(i, 1).Value <> "" Then
        Cells(i, ageCol).Value = Cells(i, ageCol).Value & " " & Cells(i, ageCol).Offset(1, 0).Value
        Cells(i, addressCol).Value = Cells(i, addressCol).Offset(-1, 0).Value & ", " & Cells(i, addressCol).Value & ", " & Cells(i, addressCol).Offset(1, 0).Value
        Cells(i, phoneCol).Value = Cells(i, phoneCol).Offset(1, 0).Value
        ' Now, let's clear the data we copied over.
        Cells(i, ageCol).Offset(1, 0).Value = ""
        Cells(i, addressCol).Offset(-1, 0).Value = ""
        Cells(i, addressCol).Offset(1, 0).Value = ""
        Cells(i, phoneCol).Offset(1, 0).Value = ""
    End If
Next i

'Now, let's delete all the empty rows
For i = 1 To endRow
    If i > endRow Then Exit For
    If IsEmpty(Cells(i, 1)) Then
        Cells(i, 1).EntireRow.Delete
        i = i - 1
        endRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    End If
Next i

End Sub

注意：这假设您的数据总是看起来像您的问题 - 上面带有名称的行上面有一行，下面有一行需要移动到名称的行。请让我知道什么有效/什么不起作用，需要调整。祝你好运！

Answer 2

多个公式（非VBA）解决方案：

此选项是使用公式和自动填充来使值显示在另一个工作表中。

注意：此选项假设所有您的数据如图所示，目前我没有考虑任何例外情况（可以添加）

以下是公式（使用＆＃34; Sheet1＆＃34;作为参考表，将其更改为您的工作表名称）：

（水平视图，..有趣的滚动..）

    A                                 B                                 C                                 D                                                                                         E                                                                                                                  F
----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
1|  Id                                Patient_Name                      Sex                               DOB_Age                                                                                   Address                                                                                                           Phone
2|  =INDIRECT("Sheet1!A"&(ROW()-1)*3) =INDIRECT("Sheet1!B"&(ROW()-1)*3) =INDIRECT("Sheet1!C"&(ROW()-1)*3) =TEXT(INDIRECT("Sheet1!D"&(ROW()-1)*3),"m/d/yyy")&", "&INDIRECT("Sheet1!D"&(ROW()-1)*3+1) =INDIRECT("Sheet1!E"&(ROW()-1)*3-1)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3+1) =INDIRECT("Sheet1!F"&(ROW()-1)*3+1)
3| ..Autofill down..

（垂直视图）

Id                                
=INDIRECT("Sheet1!A"&(ROW()-1)*3)   
Patient_Name
=INDIRECT("Sheet1!B"&(ROW()-1)*3)
Sex 
=INDIRECT("Sheet1!C"&(ROW()-1)*3)
DOB_Age 
=TEXT(INDIRECT("Sheet1!D"&(ROW()-1)*3),"m/d/yyy")&", "&INDIRECT("Sheet1!D"&(ROW()-1)*3+1)
Address 
=INDIRECT("Sheet1!E"&(ROW()-1)*3-1)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3)&", "&INDIRECT("Sheet1!E"&(ROW()-1)*3+1)
Phone
=INDIRECT("Sheet1!F"&(ROW()-1)*3+1)

现在由于这些是公式而不是vba，如果源更改，数据将自动更改。因此，如果您只想在新工作表上保留值copy -> paste special -> values，只保留值

Answer 3

Sub Parse_Data()
    Dim rngTarget As Range, x As Long

    Set rngTarget = Worksheets("Target").Range("A2")

    For x = 2 To Range("E1").Offset(Rows.Count - 1).End(xlUp).Row
        Select Case x Mod 3
            Case 2
                rngTarget.Offset(, 5).Value = Range("A1").Offset(x - 1, 4).Value
            Case 0
                rngTarget.Offset(, 0).Value = Range("A1").Offset(x - 1, 0).Value
                rngTarget.Offset(, 1).Value = Range("A1").Offset(x - 1, 1).Value
                rngTarget.Offset(, 2).Value = Range("A1").Offset(x - 1, 2).Value
                rngTarget.Offset(, 3).Value = Range("A1").Offset(x - 1, 3).Value
                rngTarget.Offset(, 6).Value = Range("A1").Offset(x - 1, 4).Value
            Case 1
                rngTarget.Offset(, 4).Value = Range("A1").Offset(x - 1, 3).Value
                rngTarget.Offset(, 7).Value = Range("A1").Offset(x - 1, 4).Value
                rngTarget.Offset(, 8).Value = Range("A1").Offset(x - 1, 5).Value
                Set rngTarget = rngTarget.Offset(1)
        End Select
    Next x
End Sub