Loop to repeat the Function and copy paste the result into Sheet

0

Looking for a code i have tried but could not make. Looking forward to your response.

When code will run

It will take Sheet("Data") Col"B" first value i.e, 00202_0000 and match that in Sheet("Data") Col"E".

If such value exists then its rows will be copied that Rows are 7, 8 and 9 into Sheet Sheet("PasteData") as i pasted in attached Book1.

and after that whatever value is appear in Sheet("Calc").Range("AE10:AG10") that will be copied and paste into Sheet("Final").Range("E2:G2").

To go for 2nd number Code will erase the previous data available in Sheet("PasteData")

Now code will repeat same function for 2nd Number It will take Sheet("Data") Col"B" 2nd value i.e., 00203_0000 and match that in Sheet("Data") Col"E".

If such value is exists then its rows will be copied that Rows are 13, 14 and 15 into Sheet("PasteData") as i pasted in attached Book2.

and after that whatever value is appear in Sheet("Calc").Range("AE10:AG10") that will be copied and paste into Sheet("Final").Range("E3:G3").

To go for 3rd number Code will erase the previous data available in Sheet("PasteData")

Now code will repeat same function for 3rd Number It will take Sheet("Data") Col"B" 3rd value i.e., 00204_0000 and match that in Sheet("Data") Col"E".

If such value is exists then its rows will be copied that rows are 20, 21 and 22 into Sheet Sheet("PasteData") as i pasted in attached Book3 and

after that whatever value is appear in Sheet("Calc").Range("AE10:AG10") that will be copied and paste into Sheet("Final").Range("E4:G4").

I just need the result that is available in Book3.Sheet("Final") for mentioned three numbers.

Three workbooks have been created to understand the scenario code will RUN in single workbook to give the accurate result as available in Workbook3

Your help will be highly appreciated.

Sub Mu_code()

Dim SearchRange As Range
Set SearchRange = ActiveWorkbook.Worksheets("PasteData").Range("C10:C1500")
Dim SearchInRange As Range
Set SearchInRange = ActiveWorkbook.Worksheets("Data").Range("H6:CL6")
Dim Cell As Range
Dim Search As String

'1st
For Each Cell In SearchRange
 If Cell.Value = 2020 Then
 Search = "Q" & Application.WorksheetFunction.RoundUp((Cell.Offset(0, 1).Value / 3), 0) & " " & Cell.Value
 Cell.Offset(0, 4).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(1))
 Else
 Search = "Y" & Cell.Value
 Cell.Offset(0, 4).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(1))
 End If
Next Cell

'2nd
For Each Cell In SearchRange
 If Cell.Value = 2020 Then
 Search = "Q" & Application.WorksheetFunction.RoundUp((Cell.Offset(0, 1).Value / 3), 0) & " " & Cell.Value
 Cell.Offset(0, 5).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(2))
 Else
 Search = "Y" & Cell.Value
 Cell.Offset(0, 5).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(2))
 End If
Next Cell

'3rd
For Each Cell In SearchRange
 If Cell.Value = 2020 Then
 Search = "Q" & Application.WorksheetFunction.RoundUp((Cell.Offset(0, 1).Value / 3), 0) & " " & Cell.Value
 Cell.Offset(0, 6).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(3))
 Else
 Search = "Y" & Cell.Value
 Cell.Offset(0, 6).Value = Application.WorksheetFunction.SumIf(SearchInRange, Search, SearchInRange.Offset(3))
 End If
Next Cell

 
[/CODE]End Sub
Answer
Discuss

Discussion

Hi I think I know what you're trying to do but notice that each workbook has links (which I don't have) - what do these do please?

Also please let me know:

1)  Is it realistic to forecast wages so many years into the future? (You have all remaining years in this century!) If not, up to which year are you being asked to forecast total wages?

2) If it helps asolution, could the data in PasteData be transposed into a new sheet (i.e. the rows converted into columns (using PasteSpecial/Transpose)?

3) Can macros be based on Book1 (i.e. does it have the correct data in Data and PasteData sheets)?
John_Ru (rep: 1002) Jan 14, '21 at 6:49 am
Hi I think I know what you're trying to do but notice that each workbook has links (which I don't have) - what do these do please?
No, each workbook has no link. Code will work for single workbook. I have attached these three workbook to understand that what i want. Otheriwse code will run on single workbook.

1)  Is it realistic to forecast wages so many years into the future? (You have all remaining years in this century!) If not, up to which year are you being asked to forecast total wages?

No, I have to do for future as well

2) If it helps asolution, could the data in PasteData be transposed into a new sheet (i.e. the rows converted into columns (using PasteSpecial/Transpose)?

Excatly i am doing the same thing with my code that takes the row and paste into Columns with the sequence.


3) Can macros be based on Book1 (i.e. does it have the correct data in Data and PasteData sheets)?
Yes each work book has accurate data.
ExcelBegginer (rep: 2) Jan 14, '21 at 7:14 am
Add to Discussion

Answers

0
Selected Answer

Hi

Here's another way of doing what you want- It does NOT use the intermediary PasteData or Calc sheets but instead calculates the sums of Wage, Lable and DD as it runs through columns.

Run the macro from Module 1 in the attached file (doesn't matter which sheet you're on) and it will populate the table in Final with the values. It avoids a PasteData sheet by multiplying a cell value by 12 (months in a year) if the heading in row 6 of Data starts with a  "Y" or by 3 (months in a Quarter) if the heading starts "Q"(and by 1 if you decided to have Monthly values, "M").

Some parts of the macro have fixed ranges (like it goes no further than column CL in calculating sums) but it will cater for codes added to Data B7:B9 (e.g. copy B7 to B10 and you'll see it repeats a row in the table in Final. This is to allow you to add more data set in E:CL. Note that it relies on the headings in row 6 to start Y, Q or M (or it will ignore the values in the sum).

Currently it gives you a message when it's done but you could delete the associated lines starting MessOut... and MsgBox...

The macro is commented (and indented) so I hope you can follow what it does.

Sub SumPerCode()

Dim Fnd As String, FnlRw As Integer
Dim Wage As Double, Lable As Double, DD As Double
Dim Mult As Integer, rw As Integer, col As Integer

On Error Resume Next

Sheet3.Range("A2:G14").ClearContents  ' Clear the table in Final
FnlRw = 1 'Set the row counter for table in Final

With Sheet1

    Set SearchRange = .Range("B7:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
    For Each Code In SearchRange

        Fnd = Code.Text

        For rw = 1 To 100 'find first row containing code
            If Left(.Cells(rw, 5), Len(Fnd)) = Fnd Then Exit For
        Next rw

        If rw = 101 Then MsgBox Fnd & " not found in column E" ' not found

        Mult = 0 '(re)initalise counters
        Wage = 0
        Lable = 0
        DD = 0

        FnlRw = FnlRw + 1 ' increment the counter each time a first row is found

        For col = 8 To 90 '= columns H to CL
            If Left(.Cells(6, col), 1) = "M" Then Mult = 1 'see if column header is Monthly, Quarterly or Yearly
            If Left(.Cells(6, col), 1) = "Q" Then Mult = 3
            If Left(.Cells(6, col), 1) = "Y" Then Mult = 12

            Wage = Wage + Mult * Round(.Cells(rw, col), 2) 'increase each sum by (rounded) number found*multiplier
            Lable = Lable + Mult * Round(.Cells(rw + 1, col), 2)
            DD = DD + Mult * Round(.Cells(rw + 2, col), 2)
        Next col

        LastHeader = .Cells(6, col - 1)

        With Sheet3 'transfer values to Final using FnlRw counter

            .Cells(FnlRw, 1) = Fnd
            .Cells(FnlRw, 5) = Wage
            .Cells(FnlRw, 6) = Lable
            .Cells(FnlRw, 7) = DD
        End With

    MessOut = MessOut & Fnd & " totals to " & LastHeader & "- Wage=" & Wage & "; Lable=" & Lable & "; DD=" & DD & Chr(13)

    Next Code

    MsgBox "Calculated for Final table:" & Chr(13) & MessOut

End With

End Sub
Hope this helps.
Discuss

Discussion

Thank you soo much, You are genius.
ExcelBegginer (rep: 2) Jan 15, '21 at 7:08 am
Thanks but I'm really not! I like to solve a puzzle but there are others on the Forum better than me. Keep learning, especially from Don's big collection of tutorials. 
John_Ru (rep: 1002) Jan 15, '21 at 8:01 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login