Loop though workbook and insert a function in each worksheet

[Bamerand]

Hi there,

Can anybody assist me with the following? I need to re-develop a macro that enters a formula into each worksheet within a workbook. The workbook has 25 worksheet and I need to insert a formulat that divided the last reading in the columns "C", "G", "E" and "I". Here is what I was able to come with:

Sub Test()
Dim rng As Range

Set rngC = Range("C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set rngE = Range("E" & Cells(Rows.Count, "E").End(xlUp).Row)
Set rngG = Range("G" & Cells(Rows.Count, "G").End(xlUp).Row)
Set rngI = Range("I" & Cells(Rows.Count, "I").End(xlUp).Row)

rngC.Offset(1, 0).Value = rngC / 14.5
rngE.Offset(1, 0).Value = rngE / 14.5
rngG.Offset(1, 0).Value = rngG / 14.5
rngI.Offset(1, 0).Value = rngI / 14.5

End Sub

When I run the code, it work perfectely and inserts the formula into desired destination (divides last value in any of the columns "C", "G", "E" and "I"). But, what I can not do is make code loop so that the macro is applied for the entire workbook and spares me from running the-present code at each worksheet individually. I tried this code:

Sub LoopTest()
Dim Current As Worksheet
For Each Current In Worksheets
' here i pasted the macro "Test"
Next
End Sub

But it did not work. Can anybody give a hint on how should I make it run as it should?

 

[dave3009]

Hi

Try this

Sub Test()


Dim sht As Worksheet


For Each sht In ThisWorkbook.Sheets
    
    With sht
        .Activate
        Set rngC = .Range("C" & Cells(Rows.Count, "C").End(xlUp).Row)
        Set rngE = .Range("E" & Cells(Rows.Count, "E").End(xlUp).Row)
        Set rngG = .Range("G" & Cells(Rows.Count, "G").End(xlUp).Row)
        Set rngI = .Range("I" & Cells(Rows.Count, "I").End(xlUp).Row)
        
        rngC.Offset(1, 0).Value = rngC / 14.5
        rngE.Offset(1, 0).Value = rngE / 14.5
        rngG.Offset(1, 0).Value = rngG / 14.5
        rngI.Offset(1, 0).Value = rngI / 14.5
    End With
    
Next sht
End Sub

 

[njimack]

That seems to be quite an inefficient way of writing values to cells. I'd go with the below (untested) code...

Sub Test()
Dim ws As Worksheet
Dim i As Long


Application.ScreenUpdating = False


For Each ws In ThisWorkbook.Worksheets
    For i = 3 To 9 Step 2
        With ws.Cells(Rows.Count, i).End(xlUp)
            .Offset(1) = .Value / 14.5
        End With
    Next i
Next ws
       
Application.ScreenUpdating = True


End Sub

 

[kevatarvind]

try below

Sub Test()
Dim my As Integer
Sheets(1).Select
my = ThisWorkbook.Worksheets.Count
Do Until ActiveSheet.name = my
Set rngC = Range("C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set rngE = Range("E" & Cells(Rows.Count, "E").End(xlUp).Row)
Set rngG = Range("G" & Cells(Rows.Count, "G").End(xlUp).Row)
Set rngI = Range("I" & Cells(Rows.Count, "I").End(xlUp).Row)
rngC.Offset(1, 0).Value = rngC / 14.5
rngE.Offset(1, 0).Value = rngE / 14.5
rngG.Offset(1, 0).Value = rngG / 14.5
rngI.Offset(1, 0).Value = rngI / 14.5
On Error GoTo GetLost
ActiveSheet.Next.Select
Loop
GetLost:
End Sub

 

[Bamerand]

Dear all,

All three options worked out in perfect. Saves me from burden of work. Is there a chance to amend the code to a way so that the final results are copied and pasted into a seperate sheet? I need to have it the data from all 25 worksheets merged into a single worksheet.

Thanks a lot in advance and regards.

 

[kevatarvind]

try below code

Sub Test()
Dim my As Integer
Sheets(1).Select
my = ThisWorkbook.Worksheets.Count
Do Until ActiveSheet.Name = my
Set rngC = Range("C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set rngE = Range("E" & Cells(Rows.Count, "E").End(xlUp).Row)
Set rngG = Range("G" & Cells(Rows.Count, "G").End(xlUp).Row)
Set rngI = Range("I" & Cells(Rows.Count, "I").End(xlUp).Row)
rngC.Offset(1, 0).Value = rngC / 14.5
rngE.Offset(1, 0).Value = rngE / 14.5
rngG.Offset(1, 0).Value = rngG / 14.5
rngI.Offset(1, 0).Value = rngI / 14.5
On Error GoTo GetLost
ActiveSheet.Next.Select
Loop
GetLost:
Dim ws As Worksheet
Sheets(1).Select
Sheets.Add.Name = "Result"
For Each ws In ThisWorkbook.Worksheets
With ws
.Range("C" & Rows.Count).End(xlUp).Copy Sheets("Result").Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
.Range("E" & Rows.Count).End(xlUp).Copy Sheets("Result").Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
.Range("G" & Rows.Count).End(xlUp).Copy Sheets("Result").Range("G" & Rows.Count).End(xlUp).Offset(1, 0)
.Range("I" & Rows.Count).End(xlUp).Copy Sheets("Result").Range("I" & Rows.Count).End(xlUp).Offset(1, 0)
End With
Next ws
End Sub

 

[Bamerand]

Dear kevatarvind,

Thanks for the code, but, no, it did not work. It pasted four "0" in the columns corresponding in "C", "E", "G" and "I". Any clues if this can be changed?

 

[Bamerand]

Dear kevatarvind,

Thanks for the code, but, no, it did not work. It pasted four "0" in the columns corresponding in "C", "E", "G" and "I". Any clues if this can be changed?

 

[kevatarvind]

dear kevatarvind,

thanks for the code, but, no, it did not work. It pasted four "0" in the columns corresponding in "c", "e", "g" and "i". Any clues if this can be changed?

can you upload your sample file in any sharing site and paste the link here pls it would be easy for me ?

BCOZ THE SAME CODE WORKING IN MY FILE

 

[Bamerand]

Send me your email. I can not upload the file. Maybe I can send by email, if this is fine with you.