• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Code is not copying correct cells

olevia

New Member
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. Thank you in advance.


Option Explicit

[pre]
Code:
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
[/pre]
 
Back
Top