在Excel宏中的现有查找循环中查找

我有一个excel电子表格，其中有表单格式的值，我需要将它们转换为表格格式。示例-

Project ID/Name:    3001    Miscellaneous Improvements  
Location:   This is Project Location.   
Description:    This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description.
Justification:  This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification.
Duration:       Q1 2013 to  Ongoing     
Status:     This is some status

每个块都以项目ID/名称开头，但是，描述和对正可以根据它们所具有的文本大小而有所不同。所有的标题都在A列中。如果我使用Find作为projectd，并使用固定长度的offset，它就可以工作，但是如果对正和描述的大小不同，它们就不在正确的位置。请帮忙

您可以使用。例如：

'Split this cells when find ':" or <TABS>
[A1:A6].TextToColumns Destination:=[A1], DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, Tab:=True, OtherChar:=":", _
    FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

“查找时拆分此单元格”：“或
[A1:A6]。TextToColumns目标：=[A1]，数据类型：=xlDelimited_
TextQualifier:=xlDoubleQuote，Tab:=True，OtherChar:=”：“_
FieldInfo:=数组（数组（1，1），数组（2，1）），trailingMinusNumber:=真

据我所知，您希望将垂直“表单”转换为数据表。我建议将该数据添加到现有表中

这是密码

您需要编辑一些变量（工作表/范围名称）

公共子测试（）
'在此处插入代码以获取每个工作表及其列范围
transferFormDataToTable范围（“Sheet1！B1:B100”），工作表（2）。列表对象（1）
端接头
公共子transferFormDataToTable（yourRangeB作为Range，dbTable作为ListObject）
'引用表单数据范围
将窗体范围变暗为范围
设置formRange=YourRange b
'在目标表中创建新的ListRow
将列表器设置为ListRow
设置listR=dbTable.ListRows.Add
'将数据从表单传输到新的ListRow
将标题设置为字符串
lastHeader=“”
Dim targetColumnOffset为整数
targetColumnOffset=0
将currentColumn设置为整数
currentColumn=0
作为整数的Dim i
对于i=1到formRange.Count
'如果行的标题不为空且与前一行不同
然后我们就知道我们有了一个不同类型数据的新列
如果lastHeader的formRange（i）.Offset（0，-1）.Value和formRange（i）.Offset（0，-1）.Value）为“”，则
lastHeader=formRange（i）.偏移量（0，-1）.值
targetColumnOffset=0
currentColumn=currentColumn+1
如果结束
'此循环捕获可能已放置在输入单元格右侧列中的数据
将行字符串变暗为字符串
rowString=“”
作为整数的Dim j
j=0
做正确的事
如果formRange（i）.Offset（0，j）.值为“”，则
如果rowString=“”和targetColumnOffset=0，则
rowString=formRange（i）.偏移量（0，j）.值
其他的
rowString=rowString&“；&formRange（i）.偏移量（0，j）.值
如果结束
j=j+1
其他的
退出Do
如果结束
环
如果targetColumnOffset=0，则
范围（currentColumn）.Value=rowString
其他的
listR.Range（currentColumn）.Value=listR.Range（currentColumn.Value&rowString
如果结束
targetColumnCoffset=targetColumnCoffset+1
'如果循环似乎已结束，则退出循环
如果formRange（i）.Value=“”和formRange（i）.Offset（0，-1）.Value=“”则_
退出
接下来我
端接头

注:

Excel在使用只有1行或2行的VBA空表创建编辑时偶尔会出现奇怪的错误。我建议仅当您的表有3行以上的行时才使用此宏

如果你想要一个更完整的版本，请给我一个提示。也就是说，你最终可能会遇到这样一个问题：如果用户切换列，代码会出错

编辑

我只是根据您的要求修改了代码。不过，这最终肯定会出问题。我会认真研究说服团队，让他们知道他们需要多少才能找到更合适的工具。祝你好运

---

因此，每一行都是一个字符串，所以单元格

A6

是

状态：这是一些状态

？它不是A6=状态，B6=这是一些状态？发布您尝试过的代码。描述不是单行，对齐也是单行。我无法发布代码。嗨，安德烈，谢谢您的回复。实际上，这不仅仅是因为我只有这么多v值。我不希望表单中的表中有很多其他垃圾值。但我希望获取所有与项目相关的值。我正在寻找类似Find（）的内容在一个查找中？您的原始数据是如何构造的？是ColumnA Header，ColumnB data吗？如果是，我将根据需要编辑代码示例是的，但是，描述有时需要2行，有时需要1行，并且与合理性相同。好的，我理解。我可能会在2天内解决算法的修复问题。但是，让我强调一下：您需要通知您的团队停止使用这种（蹩脚的）方式。制作一个更好的表单供人们使用，并使用上面的宏。表单不应该到处都有不同的单元格。如果他们以可变方式使用，请使用行高来捕获更多的文本。（我还建议使用适当的项目管理程序，而不仅仅是Excel）安德烈，你给我找时间了吗？

Public Sub test()
    'insert your code to get each Worksheet and it's column range here
    transferFormDataToTable Range("Sheet1!B1:B100"), Worksheets(2).ListObjects(1)
End Sub

Public Sub transferFormDataToTable(yourRangeB As Range, dbTable As ListObject)
    ' make a reference to the form data range
    Dim formRange As Range
    Set formRange = yourRangeB

    'create a new ListRow in your target table
    Dim listR As ListRow
    Set listR = dbTable.ListRows.Add

    'transfer the data from form to the new ListRow
    Dim lastHeader As String
    lastHeader = ""
    Dim targetColumnOffset As Integer
    targetColumnOffset = 0
    Dim currentColumn As Integer
    currentColumn = 0
    Dim i As Integer
    For i = 1 To formRange.Count
        'if the row's header is not empty and different than previous row
        'then we'll know we have a new column of different type of data
        If lastHeader <> formRange(i).Offset(0, -1).Value And formRange(i).Offset(0, -1).Value <> "" Then
            lastHeader = formRange(i).Offset(0, -1).Value
            targetColumnOffset = 0
            currentColumn = currentColumn + 1
        End If

        'this loop captures data that might have been placed in columns to the right of the input cell
        Dim rowString As String
        rowString = ""
        Dim j As Integer
        j = 0
        Do While True
            If formRange(i).Offset(0, j).Value <> "" Then
                If rowString = "" And targetColumnOffset = 0 Then
                    rowString = formRange(i).Offset(0, j).Value
                Else
                    rowString = rowString & "; " & formRange(i).Offset(0, j).Value
                End If
                j = j + 1
            Else
                Exit Do
            End If
        Loop

        If targetColumnOffset = 0 Then
            listR.Range(currentColumn).Value = rowString
        Else
            listR.Range(currentColumn).Value = listR.Range(currentColumn).Value & rowString
        End If

        targetColumnOffset = targetColumnOffset + 1

        'Exit the loop if it seems to get the end
        If formRange(i).Value = "" And formRange(i).Offset(0, -1).Value = "" Then _
            Exit For
    Next i
End Sub