使用macrosalignment多行以适应Excel中的一行

我有一个奇怪的格式来自实验室的excel数据，并试图弄清楚如何将所有的病人数据放在同一行上。 下面是一个例子，单个条目以红色突出显示，因此您可以看到整个事物跨越3行：

我认为一个macros可以很好地处理这样的事情，但是录制macros是我所知道的程度。 我真的不知道如何写VBA。 我们的目标是让所有患者信息在同一行，以便可以过滤（如下所示）：

我自己弄清楚了这一点：当我意识到引用可能会根据工作表的标题而改变时，我开始录制macros和手动更改事物（用于录制）。 我可以做一个相对的参考macros，但是一遍又一遍地将光标指向正确的位置对于每个病人来说几乎和手工操作一样多。 似乎应该有这样一种说法：“三行所包含的内容都是一个”入口“，所以放在一条线上，从这里开始到这里结束”或者什么东西？

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）解决scheme：

这个选项可以使用公式将值显示在另一个工作表中并自动填充。

注意：这个选项假定你所有的数据都是如图所示，目前我没有考虑任何exception（可以添加）

以下是公式（使用“Sheet1”作为参考表，将其更改为表格名称）：

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

  ABCDEF ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 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的值copy -> paste special -> values在特定的工作表上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