Sleeper: Code is not copying correct cells

[OLEVIA]

My code is almost running perfect but it's not copying the correct cells. For example: If I want to select "LOVE", "SUNSHINE", and "TOGETHER" from Worksheet ACW cells B4,B6, and B8 and then next loop select "ALWAYS" in ACW Worksheet cell B11 and on next loop select "WONDERFUL" in ACW Worksheet cell B16 after the run of program information on the Template Worksheet is incorrect. The Template Worksheet should have the words "LOVE","SUNSHINE",and "TOGETHER" in Template worksheet cell's E15,E16 and E17 and the word "ALWAYS" by itself only in cell E65 and lastly the word "WONDERFUL" by itself only in cell E115. For some reason the program is adding more information then needed in the Template Worksheet. Please see code below along with example attachment. Thank you in advance. Please see attachment.

Option Explicit

Sub Test1()
Dim SrcSh, targetSh As String
    Dim i, x, lastRowsSource As Integer
    Dim a As Long       '<== Counter
    Dim cell As Range   '<== Counter
    Dim rngCopyFrom As Range
Application.ScreenUpdating = False
    SrcSh = "ACW-Participant"
    lastRowsSource = Sheets(SrcSh).Range("FE" & Rows.Count).End(xlUp).Row
    Sheets("Template").Visible = True
    Sheets("Template").Copy After:=Sheets(SrcSh)
    ActiveSheet.Name = "Result"
    targetSh = ActiveSheet.Name
    Sheets("Template").Visible = False
    i = 1
    x = 0
    Application.ScreenUpdating = True
    Sheets(targetSh).Range("B9") = InputBox("Provider's MA Number")
    Sheets(targetSh).Range("B10") = InputBox("Provider's Agency")
    Sheets(targetSh).Range("B11") = InputBox("Provider's Address")
    Sheets(targetSh).Range("K9") = InputBox("Program Specialist")
    Sheets(targetSh).Range("K11") = InputBox("Contact E-Mail")
    Sheets(targetSh).Range("O10") = InputBox("Monitoring Dates")
For Each cell In Sheets(SrcSh).Range("FE3:FE" & lastRowsSource)
    If cell = "UNMET" Then
        On Error Resume Next
        Set rngCopyFrom = Application.InputBox("Select the range you want to copy from", Type:=8)
        On Error GoTo 0
        If Not rngCopyFrom Is Nothing Then
            rngCopyFrom.Copy ThisWorkbook.Sheets("Result").Range("E15")
        End If
        If x > 0 Then
            i = i + 50
            Sheets("Result").Range("A1:R45").Copy
            Range("A" & i).PasteSpecial xlPasteAll
        End If
        Sheets(SrcSh).Range("E" & cell.Row).Copy
        Sheets(targetSh).Range("E12").PasteSpecial xlPasteValues
        Sheets(SrcSh).Range("A" & cell.Row).Copy
        Sheets(targetSh).Range("E14").PasteSpecial xlPasteValues
        x = x + 1
        Range("C" & 13 + i) = "Finding # " & x      '<== Finding Counter
        Range("H" & 44 + i) = x                     '<== Finding Counter
    End If
    Next cell
For a = 45 To x * 50 Step 50    '<== Page Counter
    Range("J" & a) = x          '<== Page Counter
Next a                          '<== Page Counter
Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[Teeroy]

Attachment?

[OLEVIA]

Hi Teeroy,

Please see link for attachment. Are you good at this type of coding. It appears that I can't find no one to solve it. If you do have the skills I thank you in advance for helping.

Thanks again.


http://www.vbaexpress.com/forum/showthread.php?t=45745