Loop cycle not copying and pasting correct cells

[OLEVIA]

Hello Forum,

I have code that is working but not copying the correct information as it goes through the loop cycle.
For example: If I want to select words "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 in advance. This forum is very helpful and I Thank you again.
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

[SamT]

First I feel the need to point out several coding errors. After you fix them, it may work properly.

VBA is very good at forcing one Type of variable's value into another Type of variable, but it takes CPU time and memory, and sometimes VBA makes a mistake.

These kinds of mistakes can be somewhat avoided by placing Option Explicit at the top of all modules.
Dim SrcSh, targetSh As String
Dim i, x, lastRowsSource As Integer Only targetSh and lastRowsSource are typed. If declaring multiple variables on the same line, only the last is Typed. To Type all varables on the line, you must Type each one.

Dim SrcSh As String, targetSh As String
Most indices in VBA are Longs. Typing indices as Integers forces VBA to convert them to Longs almost everytime they are used. Typing them as Variants, (i and x above,) also forces VBA to convert them almost everytime. Some indices are in fact Variants or Integers. If you know the Type it will be used as, Then use that Type. If you don't know, then use Long. VBA will still force the odd Types to fit, but will need to do so less often.

Dim i As Long, x As Long
The Range identifier, (Range("abcxyz") is a String, but Rows.Count returns a Long.
lastRowsSource = Sheets(SrcSh).Range("FE" & Rows.Count).End(xlUp).Row
lastRowsSource = Sheets(SrcSh).Range("FE" & CStr(Rows.Count)).End(xlUp).Row
For Each cell In Sheets(SrcSh).Range("FE3:FE" & CStr(lastRowsSource))


Here, you should also check If the User selected more than one Cell.
If Not rngCopyFrom Is Nothing Then
rngCopyFrom.Copy ThisWorkbook.Sheets("Result").Range("E15")
End If
If rngCopyFrom.Count > 1 Then GoTo ErrorHandler
If rngCopyFrom Is Nothing Then GoTo ErrorHandler
rngCopyFrom.Copy ThisWorkbook.Sheets("Result").Range("E15")
Again With the CStr()
Sheets(SrcSh).Range("E" & CStr(cell.Row)).Copy

Range("C" & CStr(13 + i)) = "Finding # " & CStr(x) '<== Finding Counter

For a = 45 To x * 50 Step 50 '<== Page Counter
Range("J" & CStr(a)) = x '<== Page Counter 'CStr(x) not needed because Cell can hold a number

HTH,

SamT

[snb]

As long as you use merged cells VBA will produce unpredictable results.
Start removing all merged cells from the worksheets.

You can prevent a lot of surprises reducing your code:


Sub M_snb()
Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"
Sheets("Template").Visible = False

With Sheets("Result")
.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")
For j = 1 To Application.CountIf(Sheets("ACW-Participant").Columns("FE"), "UNMET")
If j > 1 Then .Range("A1:R45").Copy .Cells(j * 50, 1)
c00 = Application.InputBox("Select the range you want to copy from", Type:=8).Address
If Not IsEmpty(c00) Then Range(c00).Copy .Range("E15")

.Range("E12") = Sheets("ACW-Participant").Cells(cl.Row, 5).Value
.Range("E14") = Sheets("ACW-Participant").Cells(cl.Row, 1).Value
Next
End With
End Sub

[OLEVIA]

Thank you so much snb. You are outstanding. I am new to Macro's and VB, but I'm learning with the help of great teachers as you and I thank you for taking the time to help. Unfortunately, when I ran the code on my end Igot a Run-time error '424' I don't know if I did something on my end but if you can explain I thank you once again. I would also like to thank SamT I can see that both of you are very talented and skillfull at what you do and hopefully in time with hard work I will be just as good as you both. Thank you.

[snb]

Probably:
Sub M_snb()
Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"
Sheets("Template").Visible = False

With Sheets("Result")
.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")

For j = 1 To Application.CountIf(Sheets("ACW-Participant").Columns("FE"), "UNMET")
If j > 1 Then .Range("A1:R45").Copy .Cells(j * 50, 1)
Set c00 = Application.InputBox("Select the range you want to copy from", Type:=8)
If Not c00 is nothing Then c00.Copy .Range("E15")

.Range("E12") = Sheets("ACW-Participant").Cells(cl.Row, 5).Value
.Range("E14") = Sheets("ACW-Participant").Cells(cl.Row, 1).Value
Next
End With
End Sub

[OLEVIA]

Still getting the Run-time error '424'

[snb]

Your feedback is to scarce to handle....

[OLEVIA]

I Believe that the Run-Time Error 424 is happening because of cl.Row I'm not sure but I believe it is the cl.Row that is causing the error. I hopes this will help clarify. Thanks snb for helping.

[snb]

You are right:

Sub M_snb()
Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"
Sheets("Template").Visible = False
With Sheets("Result")
.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")
For j = 1 To Application.CountIf(Sheets("ACW-Participant").Columns("FE"), "UNMET")
If j > 1 Then .Range("A1:R45").Copy .Cells(j * 50, 1)
Set c00 = Application.InputBox("Select the range you want to copy from", Type:=8)
If Not c00 Is Nothing Then
c00.Copy .Range("E15")
.Range("E12") = Sheets("ACW-Participant").Cells(c00.Row, 5).Value
.Range("E14") = Sheets("ACW-Participant").Cells(c00.Row, 1).Value
End if
Next
End With
End Sub

[OLEVIA]

Snb you were right about the cl.row, however now the section for the "Finding" counter is not working and the page counter is not work. Can you please add that to the code to make function work again. Thank you.

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

[sassora]

Does this help?

Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"
Sheets("Template").Visible = False

With Sheets("Result")
.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")

Sheets("ACW-Participant").Select
NumberUNMET = Application.CountIf(ActiveSheet.Columns("FE"), "UNMET")

For cnt = 1 To NumberUNMET

If cnt > 1 Then .Range("A1:R45").Copy .Cells((cnt - 1) * 50 + 1, 1)

.Range("H" & 45 + (cnt - 1) * 50) = cnt '<== Page number
.Range("J" & 45 + (cnt - 1) * 50) = NumberUNMET '<== Total pages
.Range("C" & 14 + (cnt - 1) * 50) = "Finding # " & cnt '<== Finding Counter

Set c00 = Application.InputBox("Select the range you want to copy from", Type:=8)

c00.Copy .Range("E" & 15 + (cnt - 1) * 50)
.Range("E" & 12 + (cnt - 1) * 50) = Sheets("ACW-Participant").Cells(c00.Row, 5).Value
.Range("E" & 14 + (cnt - 1) * 50) = Sheets("ACW-Participant").Cells(c00.Row, 1).Value
Next cnt
.Select
End With

[OLEVIA]

Thank you!!This is outstanding. I tried to run the Macro and it worked great. I selected one subsection on each loop, however when I select say for instance 2 subsections from the first loop cycle and 1 subsection from the next loop cycle and 1 subsection from the last cycle it added more than needed to the 'Result" Worksheet. I also realized that my cells in ACW worksheet was merge and they should not be so I unmerge them and tried to re-run the Macro but, I just kept on getting errors. I attached the new unmerge worksheet for review. Can you please update code to run with the unmerge cells. You are outstanding and I appreciate your outstanding help and I thank you so much.

[sassora]

Here is an update of the code and I've attached the workbook.

Sheets("ACW-Participant").Select
NumberUNMET = Application.CountIf(ActiveSheet.Columns("FC"), "UNMET")

With Sheets("Result")

.Cells.Clear

.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")

For cnt = 1 To NumberUNMET

Sheets("Template").Range("A1:R45").Copy .Cells((cnt - 1) * 50 + 1, 1)

.Range("H" & 45 + (cnt - 1) * 50) = cnt '<== Page number
.Range("J" & 45 + (cnt - 1) * 50) = NumberUNMET '<== Total pages
.Range("C" & 14 + (cnt - 1) * 50) = "Finding # " & cnt '<== Finding Counter

Set cl = Application.InputBox("Select the range you want to copy from", Type:=8)

cl.Copy .Range("E" & 15 + (cnt - 1) * 50)
.Range("E" & 12 + (cnt - 1) * 50) = Sheets("ACW-Participant").Cells(cl.Row, 5).Value
.Range("E" & 14 + (cnt - 1) * 50) = Sheets("ACW-Participant").Cells(cl.Row, 2).Value
Next cnt

.Select

End With

[OLEVIA]

SASSORA, you are outstanding. Thank you!!You did it!!however there is just one problem. The input box information is not pasting to the result tab for some reason and lastly. When I run the Macro and select for example cell B3 and B4 on first loop, cell B10 and B11 on the second loop, and cell B14 and B15 on last loop from the ACW worksheet the information pasted to the "Result", but if you look at the "Result" sheet after the run, B3 from the ACW should be pasted to E12 of the "Result" sheet and B4 from the ACW should be pasted to be B14 of the "Result" sheet. I attached a word document to show example of how the Result sheet should look after the run. You are almost there my friend and I thank you for you time, patience, and help. Thank you again.

[sassora]

Hi Olevia,

I have a couple of questions / comments to establish how best to proceed:
1) Would you like each unmet regulation to be dealt with on its own page, along with finding 1, 2, ...? Or is there only ever one regulation / finding per page?
2) How do you select which subsections to include? Perhaps we can automate this.

[OLEVIA]

Hi Sassora,

You are correct. There is only one regulation per page and the user has the control to select the additional finding. I see from the last one you sent, that you gave the user the option to select any thing regarding one page which is good, but having the regulation applied automatically would be great. I thank you again Sassora. I went shopping for some books yesterday to learn more about Macros and VB, but were so many VB books to choose from that I did not know which one to get to get me started. If you have any suggestion please let me know. I truly appreciate all you have done. Thank you.

[sassora]

Here's an update, if you have any questions feel free to ask.

In previous code, you seemed to want the decision criteria on the result tab (currently it is blank) - I have placed this under the regulation, which now appears without intervention. Findings are numbered (up to 3) on a given page. I fixed something else too.

I would say that most beginners' books on VBA are suitable; how the material is presented is down to personal choice. Of course, like learning a language, you're not going to sit down and learn all the words. It's the practice in applying your current vocabulary to develop solutions and seeing how others 'speak' it!



Sub L_Train()

Sheets("ACW-Participant").Select
With Sheets("Result")

.Cells.Clear
Sheets("Template").Range("A1:R45").Copy .Cells(1, 1) '<=Copy/Paste template

.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")

cnt = 0
For Each c In Application.Intersect(ActiveSheet.Columns("FC"), ActiveSheet.UsedRange)
If c = "UNMET" Then
If cnt > 1 Then .Range("A1:R45").Copy .Cells(1, 1).Offset(cnt)
.Range("E12").Offset(cnt) = c.Offset(, 2 - Columns("FC").Column) '<= Regulation (one per page)
.Range("E13").Offset(cnt) = c.Offset(, 5 - Columns("FC").Column) '<= Decision criterion (one per page)
.Range("H45").Offset(cnt) = (cnt / 50) + 1 '<= Current page number
cnt = cnt + 50
End If
Next c

NumberUNMET = cnt / 50

For cnt = 0 To NumberUNMET * 50 - 1 Step 50
.Range("J45").Offset(cnt) = NumberUNMET '<= Insert total number of pages

Set cl = Application.InputBox("Select the range you want to copy from", Type:=8)

Application.ScreenUpdating = False
cl.Copy
.Range("E15").Offset(cnt).PasteSpecial xlPasteValues ' <= Paste range values
Application.ScreenUpdating = True

For findcnt = 1 To 3
If .Range("E15").Offset(cnt + findcnt - 1) <> "" Then
.Range("C15").Offset(cnt + findcnt - 1) = _
"Finding #" & findcnt '<= Number findings
End If
Next findcnt
Next cnt
.Select
End With
End Sub

[OLEVIA]

Sassora,

Thank you for going above and beyond!!! you are great!!!I did a little queaking myself, but actually I wanted the "Finding" section on the "Result" page to be move up by 1 row, I tried to queak the code to do it but no success. Please see attachment of example. If you have some time, I would surely appreciate the update change. I thank you again from the bottom to the top of my heart for all that you have done. Thank you.

[sassora]

The code below is to populate the findings: try changing E15 to E14 and C15 to C14.

For findcnt = 1 To 3
If .Range("E15").Offset(cnt + findcnt - 1) <> "" Then
.Range("C15").Offset(cnt + findcnt - 1) = _
"Finding #" & findcnt '<= Number findings
End If
Next findcnt

[OLEVIA]

Hi Sassora,

I know you made some new modifications to the Macro and they were great, however I realize that they would not be needed. I re-modified the code to cater to what I need, but I came across a stumbling block I need the "Finding " section on the template to be incremented by 1 for each page and I tried to make the change to do it, but instead of incrementing by 1 the "Finding" section is incrementing by 50. Can you please re-modify the code to increment by 1. Therefore page 1 will indicate "Finding #1", Page 2 will indicate "Finding #2" ect,ect Please see attachment of the mods I made. Thanks again.
Sub L_Train()

Sheets("ACW-Participant").Select
With Sheets("Result")

.Cells.Clear
Sheets("Template").Range("A1:R45").Copy .Cells(1, 1) '<=Copy/Paste template

.Range("B9") = InputBox("Provider's MA Number")
.Range("B10") = InputBox("Provider's Agency")
.Range("B11") = InputBox("Provider's Address")
.Range("K9") = InputBox("Program Specialist")
.Range("K11") = InputBox("Contact E-Mail")
.Range("O10") = InputBox("Monitoring Dates")

cnt = 0
For Each c In Application.Intersect(ActiveSheet.Columns("FC"), ActiveSheet.UsedRange)
If c = "UNMET" Then
If cnt > 1 Then .Range("A1:R45").Copy .Cells(1, 1).Offset(cnt)
.Range("E12").Offset(cnt) = c.Offset(, 2 - Columns("FC").Column) '<= Regulation (one per page)
.Range("E13").Offset(cnt) = c.Offset(, 5 - Columns("FC").Column) '<= Decision criterion (one per page)
.Range("H45").Offset(cnt) = (cnt / 50) + 1 '<= Current page number
.Range("C15").Offset(cnt) = "Finding # " & cnt '<== Finding Counter
cnt = cnt + 50
End If
Next c

NumberUNMET = cnt / 50

For cnt = 0 To NumberUNMET * 50 - 1 Step 50
.Range("J45").Offset(cnt) = NumberUNMET '<= Insert total number of pages

Set cl = Application.InputBox("Select the range you want to copy from", Type:=8)

Application.ScreenUpdating = False
cl.Copy
.Range("E13").Offset(cnt).PasteSpecial xlPasteValues ' <= Paste range values
Application.ScreenUpdating = True


Next cnt
.Select
End With
Columns("A:A").ColumnWidth = 16.14
Columns("A:A").ColumnWidth = 20.14
Columns("B:B").ColumnWidth = 13.86
Columns("B:B").ColumnWidth = 16
Columns("C:C").ColumnWidth = 12.43
Columns("K:K").ColumnWidth = 11.43
Columns("F:F").ColumnWidth = 11.86
Columns("O:O").ColumnWidth = 13.71
Columns("F:F").ColumnWidth = 13.43
Columns("E:E").ColumnWidth = 9.71
Range("C15").Select
Selection.Font.Bold = True
Range("C16").Select
Selection.Font.Bold = True
Range("C65").Select
Selection.Font.Bold = True
Range("C66").Select
Selection.Font.Bold = True
Range("C115").Select
Selection.Font.Bold = True
End Sub

[sassora]

Hi Olevia, it will be the same as the page number i.e.

.Range("C15").Offset(cnt) = "Finding # " & (cnt/50)+1 '<== Finding Counter

[OLEVIA]

Thanks Sassora!!! :)

[sassora]

Don't forget to mark the post as solved!