Vba 按包含文本的行将单元格复制到另一工作表上的列

我对宏等相当陌生，几天来我一直在努力解决这个问题
我正试图从一个大的数据电子表格开始，根据特定单元格的内容选择特定单元格，然后粘贴到另一个工作表中。

源电子表格：

Private Function GetCARng(rng As Range) As Variant
Dim cel As Range, x
For Each cel In rng
    If cel.Value <> 0 Then
        If IsArray(x) Then
            ReDim Preserve x(UBound(x) + 1)
        Else
            ReDim x(1)
        End If
        x(UBound(x)) = cel.Value
    End If
Next
GetCARng = x
End Function

列go：现场、子位置、日期、月份、检查员、行动1、行动2等，每次检查最多67项行动。 每一行都是一份单独的检验报告

目标电子表格：

Private Function GetCARng(rng As Range) As Variant
Dim cel As Range, x
For Each cel In rng
    If cel.Value <> 0 Then
        If IsArray(x) Then
            ReDim Preserve x(UBound(x) + 1)
        Else
            ReDim x(1)
        End If
        x(UBound(x)) = cel.Value
    End If
Next
GetCARng = x
End Function

列go：站点、子位置、日期、月份、检查员、行动、行动到期日 其中每一行都是一个单独的操作。 我希望它跳过粘贴操作列中的任何空值（因为不需要任何操作）。粘贴操作时，它还将粘贴前5列（带有站点名称、位置、日期等），以便将操作标识到正确的站点、日期等

希望这是有道理的。最后，我希望目标电子表格能够根据人们需要的任何内容进行过滤，例如，截止日期或地点等

我尝试过最难工作的代码…不幸的是，我只能让它为第一行工作，然后它仍然粘贴空白（或零）值，我需要过滤掉它们。我在想某种循环来完成所有的行

Sub test1257pm()
Application.ScreenUpdating = False
    Sheets("Corrective Actions").Select
    Range("A3:E3").Select
    Selection.Copy
    Sheets("Corrective Actions Tracker").Select
    Range("A3").Select
    ActiveSheet.Paste

    Sheets("Corrective Actions").Select
    Range("F3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Corrective Actions Tracker").Select
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

.Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).PasteSpecial
    Rows("2:2").Select
    Selection.AutoFilter
    Range("F4").Select
    ActiveSheet.Range("$A$2:$L$300").AutoFilter Field:=6, Criteria1:=Array( _
        "CMC to conduct clean of ceiling fans. Close out by 17/04/2014", _
        "Provide bins", "Send to contractor", "="), Operator:=xlFilterValues

Application.ScreenUpdating = True
End Sub

非常感谢任何能给我任何帮助的人！：）

编辑：24-4-2014 好的，在L42的代码之后，如果我可以在将数据放入1列（堆叠）之前先对数据进行联合处理，它就可以正常工作了。我尝试过的代码（使用宏记录器）是：

我的问题是，它会产生意想不到的结果……它不会像我预期的那样将所有内容合并成行。我认为这不是最好的解决方案…可能需要更改原始宏…但是我不确定如何更改。

大修#1:使用提供的示例数据

Option Explicit '~~> These two lines are important
Option Base 1

Sub StackMyActions()

Dim sourceWS As Worksheet, targetWS As Worksheet
Dim staticRng As Range, copyRng As Range
Dim inspCnt As Long, i As Long, fRow As Long, tRow As Long
Dim myactions

Set sourceWS = ThisWorkbook.Sheets("Corrective Actions")
Set targetWS = ThisWorkbook.Sheets("Corrective Actions Tracker")

With sourceWS
    '~~> count the total inspection
    '~~> here we incorporate .Find method finding the last cell not equal to 0
    inspCnt = .Range("A3", .Range("A:A").Find(0, [a2], _
        xlValues, xlWhole).Offset(-1, 0).Address).Rows.Count
    '~~> set the Ranges
    Set copyRng = .Range("F3:BT3")
    Set staticRng = .Range("A3:E3")
    '~~> loop through the ranges
    For i = 0 To inspCnt - 1
        '~~> here we use the additional code we have below
        '~~> which is GetCARng Function
        myactions = GetCARng(copyRng.Offset(i, 0))
        '~~> this line just checks if there is no action
        If Not IsArray(myactions) Then GoTo nextline
        '~~> copy and paste
        With targetWS
            fRow = .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Row
            tRow = fRow + UBound(myactions) - 1
            .Range("F" & fRow, "F" & tRow).Value = Application.Transpose(myactions)
            staticRng.Offset(i, 0).Copy
            .Range("A" & fRow, "A" & tRow).PasteSpecial xlPasteValues
        End With
nextline:
    Next
End With

End Sub

---

获取操作的函数：

Private Function GetCARng(rng As Range) As Variant
Dim cel As Range, x
For Each cel In rng
    If cel.Value <> 0 Then
        If IsArray(x) Then
            ReDim Preserve x(UBound(x) + 1)
        Else
            ReDim x(1)
        End If
        x(UBound(x)) = cel.Value
    End If
Next
GetCARng = x
End Function

私有函数GetCARng（rng作为范围）作为变量
昏暗的cel As范围，x
对于rng中的每个cel
如果单元格值为0，则
如果是IsArray（x），那么
重读保留x（UBound（x）+1）
其他的
雷迪姆x（1）
如果结束
x（UBound（x））=单元值
如果结束
下一个
GetCARng=x
端函数

结果：
1：使用示例数据，如下所示：

2：在运行宏后，它会按如下方式堆叠数据：

以上代码仅对至少有1个操作的输入部分进行堆栈。
例如，由MsExample执行的站点3没有反映在纠正措施跟踪表上，因为没有发布任何措施。
我真的无法充分解释上面使用的所有属性和方法。
只需查看下面的链接，即可帮助您了解大多数部分：

---

当然还有练习，练习，练习。

几个澄清问题。。。1.您希望获取源工作表上的每一行，并（可能）根据源工作表中记录的操作数在目标工作表上生成许多行。对吗？2.您的代码是否需要从每个条目中解析出到期日期，还是留给用户？谢谢你的额外信息！嗨，丹，是的，没错。可能有许多行是从一行创建的。但是，原始工作表有200多列。因此，这是查看所有操作的一种更简单的方法：）到期日期将由用户手动输入，或者可能使用=IFERROR（MID（E3，FIND（“/”，E3,1）-2,10），“-”）公式从操作单元格中提取，如果他们最初正确输入了日期。谢谢所以基本上你只是想把所有的动作都放在

列中，对吗？就像你在前5列
Site，Sub Loc。。。等等。
，对吗？您想构建一个透视表。真的没有必要添加这么多的电子表格，增加文件的大小，降低文件的执行速度。您已经在电子表格上拥有了所需的所有数据，您只需要能够快速“排序”和/或显示它-使用数据透视表。您好，L42，感谢您的帮助。不幸的是，假设1不正确，操作之间会有间隙。这是因为电子表格来源于物业检查的问卷表，如果某一特定项目（如楼层状况）被标记为不满意，则需要输入纠正措施。如果一切都很好（大部分时间都是这样），那么就不要采取行动。通常情况下，在1次检查中会采取行动1…然后是行动45…然后是行动62。希望这是有道理的。同样不幸的是，一次检查可能没有任何操作。但是，是的，这正是我希望数据堆叠的方式！：）我可以让它工作时，行动放在一起（见链接红色），但行动将间隔（见链接）冷静。好的，明白了。我们可能需要稍微调整一下。您可以使用
.Filter
方法在发布的代码中找到可能的解决方案。试着打败我吗？：）好的，我不确定如何使用.Filter方法…所以我尝试合并数据以便宏可以工作…但这也不起作用。（我把代码放在上面的问题中）你做得怎么样？