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

Question

我对宏等还不是很陌生，而且我已经尝试解决这一问题了几天了！
我正在尝试从大型数据电子表格开始，根据特定单元格的内容选择特定单元格，然后粘贴到另一个工作表中。

源电子表格：

列为：站点，子位置，日期，月份，检查员，操作1，操作2等，每次检查最多67个操作。 每行是单独的检查提交

目标电子表格：

列为：站点，子位置，日期，月份，检查员，操作，操作的到期日期，其中每一行都是单独的操作。 我希望它跳过从动作列中粘贴为空的任何值（因为不需要任何动作）。 粘贴操作时，还将粘贴前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列中（堆叠），那么它可以很好地工作。 我尝试（使用宏记录器）的代码是：

Sub Macro2()

Dim r As Range
Dim i As Integer

For i = 3 To 10

Range("P" & i).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Range("F" & i).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=True, _
    IconFileName:=False

   Next i

End Sub

我的问题是，它给出了意外的结果……它并没有像我期望的那样将所有内容合并到行中。 我在想这不是最好的解决方案……可能需要更改原始宏。但是我不确定如何。

Answer 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

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

2：运行宏后，哪个将按如下所示堆叠数据：

上面的代码仅堆叠带有至少1个Action的检查。
例如，由MsExample进行的站点3不会反映在“纠正措施跟踪表”上，因为没有发布任何措施。
好吧，我真的不能对它进行足够的解释，上面使用的所有属性和方法。
只需查看以下链接即可帮助您了解大部分内容：

避免使用选择
使用.Find方法
从VBA函数返回数组

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