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

Question

I'm fairly new to macros etc..and I've been trying to figure this problem out for a few days now!
I'm trying to go from a large spreadsheet of data, selecting specific cells based on the contents of specific cells, and paste into another worksheet.

Source spreadsheet:

Columns go: Site, Sub-location, Date, Month, Inspector, Action 1, Action 2 etc up to a max of 67 actions for each inspection. Each row is a separate inspection submission

Target spreadsheet:

Columns go: Site, Sub-location, Date, Month, Inspector, Action, Due date of Action where each row is a separate action. I want it to skip pasting any values from the actions columns that would be blank (since no action is required). When it pastes the actions, it will also paste the first 5 columns (with site name, location, date etc), so that the action can be identified to the right site, date etc.

Hopefully that makes sense. By the end, I want the target spreadsheet to be able to be filtered by whatever the people need, eg by due date, or by location etc.

Code that I tried my hardest to get working...Unfortunately I can only get it working for the first row, and then it still pastes the blank (or zero) values and I need to filter them out. I'm thinking some sort of loop to do all the rows.

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

Many thanks to anyone that can give me any assistance! :)

Edit:24-4-2014 Okay so after L42's code, it works fine if I could just consodidate my data first before putting it in the 1 column (stacking). The code I tried (using Macro recorder) is:

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

My problem with this is that it gives unexpected results...it doesn't consolidate it all into rows how I would expect. I'm thinking that this isn't the best solution...and probably the original macro needs to be changed..however I'm not sure how.

Answer 1

Overhaul #1: Using the provided sample data

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

---

Function to get the actions:

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

Results:
1: Using your sample data which looks like below:

2: Which after running the macro stacks the data like below:

Above code only stack inpections with at least 1 Action.
For example, Site 3 which was conducted by MsExample do not reflect on the Corrective Actions Tracker Sheet since no action was posted.
Well I really can't explain it enough, all the properties and methods used above.
Just check out the links below to help you understand most parts:

Avoid Using Select
Using .Find Method
Returning Array From VBA Function

And of course practice, practice, practice.