VBA Macro Loop Through worksheet

L

LearnVBA83

Board Regular
Joined
Dec 1, 2016
Messages
109
Office Version
  1. 365
Platform
  1. Windows
Is there a way to write a macro that will loop through each worksheet in workbook and copy the name of the worksheet into that worksheet in cell A1 to A200?
 
Sort by date Sort by votes
try this

VBA Code: 
Option Explicit

Private Const GLFilePath As String = ""  ' ie C:\Docs\GL\2024 Data File.xlsx
Private Const Wages As Long = 6120110
Private Const Merit As Long = 6120807
Private Const Fica As Long = 6120605
Private Const Benefits As Long = 6030610
Private Const Contingent As Long = 6130202

Public Sub HandleGLAndContingentWorksheets()

    Dim wb As Workbook
    Dim ws As Worksheet, mst As Worksheet, mstTemp As Worksheet
    Dim numericPart As String, char As String
    Dim i As Integer, x As Integer, wsCnt As Integer
    Dim lr As Long, monRow As Long, expRow As Long, hasGLNum As Long
    Dim rng As Range, cRow As Range, fillRangeRow As Range, target As Range
    Dim ar As Variant
    Dim sumMonths(1 To 12) As Double, contTest As Double
    Dim writeContingent As Boolean

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set mst = ThisWorkbook.Sheets("Master")
    Set wb = Workbooks.Open(GLFilePath)
    
    ' add a temp mst to put all value to prior transfer to Master
    On Error Resume Next
    wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "mstTemp"
    On Error GoTo 0
    Set mstTemp = wb.Sheets("mstTemp")
    
    For Each ws In wb.Worksheets
        numericPart = ""
        
        For i = 1 To Len(ws.Name)
            char = Mid(ws.Name, i, 1)
            If IsNumeric(char) Then
                numericPart = numericPart & char
            End If
        Next
        
        If IsNumeric(numericPart) And Len(numericPart) = 6 Then
            With ws
                ws.Select
                
                ' for testing...don't uncomment this line
                '.Columns("A:B").Delete Shift:=xlToLeft
                
                ' check for filter ON
                If ws.AutoFilterMode Then
                    ws.AutoFilterMode = False
                End If
                             
                ' insert column and make text type to handle 000000
                .Columns("A:B").Insert Shift:=xlToRight
                .Columns("A:A").NumberFormat = "@"
                
                ' set working range
                lr = .Cells(.Rows.Count, "D").End(xlUp).row
                Set rng = .Range("D2:O" & lr)

                ' add sheet name
                .Range("A2:A" & lr).Value = "'" & numericPart

                ' loop through and sum expense
                For Each cRow In ws.Range("D2:D" & lr).Rows
                    Set target = cRow.Cells(, 1)
                    
                    ' add the GL Codes
                    If InStr(1, target.Value, "Wages", vbTextCompare) > 0 Then hasGLNum = Wages
                    If InStr(1, target.Value, "Merit", vbTextCompare) > 0 Then hasGLNum = Merit
                    If InStr(1, target.Value, "Fica", vbTextCompare) > 0 Then hasGLNum = Fica
                    If InStr(1, target.Value, "Benefits", vbTextCompare) > 0 Then hasGLNum = Benefits
                    
                    ' switch contingent tracking
                    If InStr(1, target.Value, "Total FTEs", vbTextCompare) > 0 Then writeContingent = True
                    If InStr(1, target.Value, "Wages", vbTextCompare) > 0 Then writeContingent = False
            
                    ' mark the contingent lines
                    If writeContingent And InStr(1, target.Value, "Contingent", vbTextCompare) > 0 Then
                        cRow.Cells(, -1).Value = "contingent"
                    End If

                    ' find the month row
                    If Trim(target.Offset(, 1).Value) = "Jan" Then
                        monRow = cRow.row + 1
                    End If

                    ' find  expense
                    If Trim(target.Value) = "Expense" Then
                        expRow = cRow.row
                        If hasGLNum > 0 Then target.Offset(, -1).Value = hasGLNum
                    End If


                    ' if we have both, put sum, fill across
                    If monRow > 0 And expRow > 0 Then
                        Set fillRangeRow = ws.Range(ws.Cells(expRow, 5), ws.Cells(expRow, 16))
                        fillRangeRow.Formula = "=SUM(E" & monRow & ":P" & expRow - 1 & ")"

                        monRow = 0
                        expRow = 0
                        hasGLNum = 0
                    End If

                    ' if we need to write GL do it
                    If hasGLNum > 0 Then target.Offset(, -1).Value = hasGLNum
                Next
                
                ' initialize the array
                For x = 1 To 12
                    sumMonths(x) = 0
                Next

                ' add contingent values
                For i = 1 To .UsedRange.Rows.Count
                    If .Cells(i, "B").Value = "contingent" Then
                        For x = 5 To 16
                            If IsNumeric(ws.Cells(i, x).Value) Then
                                sumMonths(x - 4) = sumMonths(x - 4) + ws.Cells(i, x).Value
                            End If
                        Next
                    End If
                Next

                ' delete contingent
                For i = ws.UsedRange.Rows.Count To 1 Step -1
                    If InStr(1, ws.Range("D" & i).Value, "Contingent", vbTextCompare) > 0 Then
                       ws.Cells(i, 1).EntireRow.Delete
                    End If
                Next
    
                ' overwrite with just values
                With .UsedRange
                    .Value = .Value
                End With

                ' copy expenses to master temp
                lr = mstTemp.Cells(.Rows.Count, "A").End(xlUp).row + 1
                mstTemp.Columns("A:A").NumberFormat = "@"
                For i = 1 To .UsedRange.Rows.Count
                    If InStr(1, ws.Range("D" & i).Value, "Expense", vbTextCompare) > 0 And ws.Range("C" & i).Value <> "" Then
                        Set fillRangeRow = ws.Range(ws.Cells(i, 1), ws.Cells(i, 16))
                        Set rng = mstTemp.Cells(lr, 1)
                        Set rng = rng.Resize(1, fillRangeRow.Columns.Count)
                        rng.Value = fillRangeRow.Value
    
                        lr = lr + 1
                    End If
                Next

                ' test and copy contingent to master file
                contTest = 0
                For x = 1 To 12
                   contTest = contTest + sumMonths(x)
                Next
                
                If contTest > 0 Then
                    With mstTemp
                        lr = .Cells(.Rows.Count, "A").End(xlUp).row + 1
                        .Range("A" & lr).Value = numericPart
                        .Range("C" & lr).Value = Contingent
                        .Range("D" & lr).Value = "Contingent"
                        For x = 1 To 12
                           .Cells(lr, x + 4).Value = sumMonths(x)
                        Next
                    End With
                End If
            End With

            ' count ws success
            wsCnt = wsCnt + 1
        End If
        numericPart = ""
    Next

    ' clean up msttemp
    With mstTemp
        .Cells(, 2).EntireColumn.Delete
        .Rows("1:2").Insert Shift:=xlDown
        .Range("A1:E1").Merge
        .Range("A1").Value = "Ws Success Count: " & wsCnt & Space(10) & Format(Now(), "mm/dd/yyyy hh:mm:ss AM/PM")
        .Range("A3:O3").Value = Array("Cost Center", "GL Account", "Type", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
        .Columns("A:A").NumberFormat = "@"
    End With

    ' copy to masterfile
    ar = mstTemp.UsedRange.Value
    mst.UsedRange.Clear
    mst.Columns("A:A").NumberFormat = "@"
    Set rng = mst.Range("A1").Resize(UBound(ar, 1), UBound(ar, 2))
    rng.Value = ar

    ' some formmating
    With mst
        .Rows("3").Font.Bold = True
        .Range("D:O").HorizontalAlignment = xlRight
        .Columns("D:O").AutoFit
        .Range("D:O").NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
    End With

    ' delete the mstTemp sheet
    mstTemp.Delete

    ' close the wb
    wb.Close SaveChanges:=True

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    Set wb = Nothing
    Set ws = Nothing
    Set mst = Nothing
    Set mstTemp = Nothing
End Sub
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Wow this worked. The only thing I did was added in my dialog box code and then i got a debug error here at ws.Select. I deleted that little piece and it seems to be working perfectly. I assume it's ok that i deleted that piece?

VBA Code: 
If IsNumeric(numericPart) And Len(numericPart) = 6 Then
            With ws
                ws.Select
                
                ' for testing...don't uncomment this line
                '.Columns("A:B").Delete Shift:=xlToLeft
                
                ' check for filter ON
                If ws.AutoFilterMode Then
                    ws.AutoFilterMode = False
                End If
                             
                ' insert column and make text type to handle 000000
                .Columns("A:B").Insert Shift:=xlToRight
                .Columns("A:A").NumberFormat = "@"
                
                ' set working range
                lr = .Cells(.Rows.Count, "D").End(xlUp).row
                Set rng = .Range("D2:O" & lr)
 
Upvote 0
Yep, I was using that to debug. It SHOULD be deleted.

Glad it's working :)
 
Upvote 0
I just thought about adding a possible reconciling check in the template. Once we run the macro the sum of all numbers on the master template (Image 1). Should tie exactly to the "Total Cost" amount in column O of each ws that the macro looped through added together (image 2). Would you add something at the end of the macro that loops through the worksheets again, grabs the "Total Cost" total expense number in column O, adds them all together and then compares to the total of what was pulled into the master template? In this case my master template total is 339,100,772.94. If I flip through each worksheet and grab the grand total in the total cost section they should all add to the same number and tie. Is this crazy to try to do?



1707680776194.png



1707680900219.png
 
Upvote 0
I would capture the value while I'm on the sheet and just keep adding to it. I wouldn't loop again.

Then copy it to the master next to a total column for the check.
 
Upvote 0
Would you do this like how you did the contingent with an array to store it? I think I probably need the code below like how you did the contingent to isolate the Total Cost section. How should I write cRow.Cells so it only picks up the amount in Column Q where the word "Expense" is in Column D in the Total cost area? Also, do i store each value (since it's only one amount per worksheet) and then sum them at the end or is there code that basically tell it to keep adding to the amount? This is so fun! My eyes burn though looking at the screen so long trying to study your code.


VBA Code: 
                    ' switch Grand Total tracking
                    If InStr(1, target.Value, "Total FTEs", vbTextCompare) > 0 Then writeGrandTotal = True
                    If InStr(1, target.Value, "Wages", vbTextCompare) > 0 Then writeGrandTotal = False

  ' Grab Grand Total Line
                    If writeGrandTotal And InStr(1, target.Value, "Expense", vbTextCompare) > 0 Then
                        cRow.Cells("Q")?????
                    End If
 
Upvote 0
To be clear you only need your full year column total ie "Total Cost" Section. Cell 042 in the below example for each sheet. You also may have a contingent row in the total sum (sometimes).

2024 - Budget - Finance Results-Fake Data - 1 - Copy (8) - Copy.xlsx
BCDEFGHIJKLMNO
25Site Of Care - Total CostJan FebMarAprMayJunJulAugSepOctNovDecFull Year
26Manager$ 20,055$ 20,055$ 20,055$ 20,565$ 20,565$ 20,565$ 20,565$ 20,565$ 20,565$ 20,565$ 20,565$ 20,565$ 245,251
27Nurse Associate$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
28Sr Analyst$ 15,871$ 15,871$ 15,871$ 16,275$ 16,275$ 16,275$ 16,275$ 16,275$ 16,275$ 16,275$ 16,275$ 16,275$ 194,086
29Supervisor$ 11,624$ 11,624$ 11,624$ 11,919$ 11,919$ 11,919$ 11,919$ 11,919$ 11,919$ 11,919$ 11,919$ 11,919$ 142,143
30Tech$ 153,210$ 153,210$ 153,210$ 164,338$ 164,338$ 149,398$ 164,338$ 164,338$ 149,398$ 171,808$ 149,398$ 156,868$ 1,893,849
310$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
320$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
330$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
340$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
350$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
360$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
370$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
380$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
390$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
400$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
410$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
42Expense##################213,096213,096198,157213,096213,096198,157######198,157######$2,475,329
401274
 
Upvote 0
You're correct. So the macro you built pulls in all the total cost but separates them into wage, merit, fica, benefit, and contingent. So the grand total of everything that you pulled into the master should be equal to the O42 of every worksheet added together (It may not always be O42 but it should always be in the total cost section where the line name I believe in column D = "Expense" and then the amount in column "O"
 
Upvote 0
Since that is a total column in a total section it will always have the largest number on the sheet.

Create a private variable: ie
Dim totalCost as double and keep adding to it each sheet

after you the contingent lines are deleted

totalCost = totalCost + Application.WorksheetFunction.Max(rng) ' find the column of your totals

write that out to your mastertemp and bring it across.

Something like that should work
 
Upvote 0
skillilea said:
Since that is a total column in a total section it will always have the largest number on the sheet.

Create a private variable: ie
Dim totalCost as double and keep adding to it each sheet

after you the contingent lines are deleted

totalCost = totalCost + Application.WorksheetFunction.Max(rng) ' find the column of your totals

write that out to your mastertemp and bring it across.

Something like that should work
Click to expand...
I want to include the contingent in the total as well does that change things?
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Step 1: Can you Loop Through Multiple Excel worksheets in one workbook (Copy and paste all to new worksheet or Workbook)
Replies
9
Views
421
Micron
M
A
  • Solved
Make vba macro functional for all workbooks
Replies
8
Views
65
abramo
A
Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
210
qplsn9
Q
franklin_m
  • Question
VBA Search row for instances of pattern in two adjacent cells
Replies
3
Views
123
franklin_m
franklin_m
R
  • Question
Help! VBA to loop through a list containing data references to update forecast sheets automatically
Replies
3
Views
127
Domenic
D

Forum statistics

Threads
1,215,098
Messages
6,123,082
Members
449,094
Latest member
mystic19

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top