PDA

View Full Version : Sleeper: Code is not copying correct cells



OLEVIA
03-26-2013, 04:25 PM
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
03-26-2013, 09:20 PM
Attachment?

OLEVIA
03-28-2013, 03:47 AM
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