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

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Worked fine. I see the issue. I'll get at it in a bit. Simple fix.
 
Upvote 0
skillilea said:
Worked fine. I see the issue. I'll get at it in a bit. Simple fix.
Click to expand...
You're amazing! I'd love to know what the issue is. Also, how did you get so good at this? I will study your code, but I feel like there are 1,000s of use cases for VBA at my job.
 
Upvote 0
Thanks :)

I am on purpose writing this top down so you can learn a bit caught that in your LearnVBA83. For production I would most likely break this out into smaller subs/functions and apply a lot more error checking. Let's get it running first.

Error was Activesheet on the filter. Also, I am changing where the master sheet gets built up.

Give me a bit.

sk
 
Upvote 0
Ok, it has to be close

VBA Code: 
Option Explicit

Private Const GLFilePath As String = "C:\Users\username\OneDrive - FreedomDev\Desktop\GL\2024 - Budget - Finance Results-Fake Data.xlsx"  ' 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

Public Sub HandleRelevantWorksheets()
    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, wsCnt As Integer
    Dim lr As Long, monRow As Long, expRow As Long
    Dim rng As Range, cRow As Range, fillRangeRow As Range, target As Range
    Dim hasGLNum As Long
    Dim ar As Variant
   
    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
                ' for testing...don't uncomment this line
                '.Columns("A:A").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:A").Insert Shift:=xlToRight
                .Columns("A:A").NumberFormat = "@"
               
                ' set working range
                lr = .Cells(.Rows.Count, "C").End(xlUp).row
                Set rng = .Range("C2:O" & lr)
               
                ' add sheet name
                .Range("A2:A" & lr).Value = "'" & numericPart
               
                ' loop through and sum expense
                For Each cRow In ws.Range("C2:C" & 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
                   
                    ' 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, 4), ws.Cells(expRow, 15))
                        fillRangeRow.Formula = "=SUM(D" & monRow & ":D" & 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
               
                ' delete contingent
                For i = ws.UsedRange.Rows.Count To 1 Step -1
                    If InStr(1, ws.Range("C" & 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("C" & i).Value, "Expense", vbTextCompare) > 0 Then
                        Set fillRangeRow = ws.Range(ws.Cells(i, 1), ws.Cells(i, 15))
                        Set rng = mstTemp.Cells(lr, 1)
                        Set rng = rng.Resize(1, fillRangeRow.Columns.Count)
                        rng.Value = fillRangeRow.Value
   
                        lr = lr + 1
                    End If
                Next
            End With

            ' count ws success
            wsCnt = wsCnt + 1
        End If
        numericPart = ""
    Next
   
    ' clean up msttemp
    With mstTemp
        .Cells(, 3).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:N3").Value = Array("Sheet", "GL Account", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    End With

    ' copy to masterfile
    ar = mstTemp.UsedRange.Value
    mst.UsedRange.Clear
    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("C:N").HorizontalAlignment = xlRight
        .Columns("C:N").AutoFit
        .Range("C:N").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


example output

Master.xlsm
ABCDEFGHIJKLMN
1Ws Success Count: 46 02/02/2024 10:11:23 AM
2
3SheetGL Account Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
481695,225,7144,951,6134,922,6605,100,9755,226,5424,886,5905,176,9475,016,7624,870,1994,985,4654,737,7874,770,140
5816961201104,307,1634,083,3164,063,7974,103,2944,202,4913,940,7354,167,9104,040,8683,926,4564,011,6353,816,6223,839,347
681696120807---124,003127,108118,581125,317121,567117,943120,822115,043115,805
781696120605359,778342,663338,833343,489352,089328,468347,129336,741326,702334,676318,669320,780
881696030610558,773525,635520,030530,189544,855498,805536,591517,586499,098518,332487,453494,207
98179277,868271,702271,702281,664284,821275,351284,821281,664278,508284,821278,508281,664
1081796120110231,773226,867226,867229,320231,773224,414231,773229,320226,867231,773226,867229,320
1181796120807---6,8806,9536,7326,9536,8806,8066,9536,8066,880
128179612060519,26018,85318,85319,05719,26018,64919,26019,05718,85319,26018,85319,057
138179603061026,83425,98225,98226,40826,83425,55726,83426,40825,98226,83425,98226,408
14750050649,289648,269648,269665,252665,774664,208657,501656,979656,457665,774664,730665,252
157500506120110549,502548,690548,690549,096549,502548,284542,666542,261541,855549,502548,690549,096
167500506120807---16,47316,48516,44916,28016,26816,25616,48516,46116,473
17750050612060545,66445,59645,59645,63045,66445,56245,09645,06245,02845,66445,59645,630
18750050603061054,12453,98353,98354,05354,12453,91353,45953,38953,31954,12453,98354,053
19750105204,345197,328197,328205,822209,414198,637209,414205,822202,230209,414202,230205,822
207501056120110168,978163,394163,394166,186168,978160,602168,978166,186163,394168,978163,394166,186
217501056120807---4,9865,0694,8185,0694,9864,9025,0694,9024,986
22750105612060514,04213,57813,57813,81014,04213,34614,04213,81013,57814,04213,57813,810
23750105603061021,32520,35620,35620,84021,32519,87121,32520,84020,35621,32520,35620,840
24296135-------(4,082)27,98757,07290,94831,078
252961356120110-------(4,082)22,70146,71271,03911,992
262961356120807--------7541,4782,8402,723
272961356120605--------2,0894,0947,8677,542
282961356030610--------2,4434,7889,2028,821
2911284,649,9774,520,8784,832,1364,246,1184,389,1574,542,3503,754,5614,188,8873,850,3164,139,9404,686,7784,815,523
30112861201103,831,3023,732,1103,994,4043,424,3153,533,9493,666,7803,019,6353,378,7473,107,1633,330,3023,767,5543,862,857
Master
 
Last edited:
Upvote 0
Wow I ran it on one tab and it worked on one. Question. What can we do to make it paste the whole 6 digits in the master? I'm going to use the results to load into SAP so it'll have to be the full 6 digits. Also can you make it delete those lines that don't have a GL code? They represent the total of all and aren't relevant b/c they won't be loaded

1706889159347.png
 
Upvote 0
try this

VBA Code: 
Option Explicit

Private Const GLFilePath As String = "C:\Users\SeanKillilea\OneDrive - FreedomDev\Desktop\GL\2024 - Budget - Finance Results-Fake Data.xlsx"  ' 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

Public Sub HandleRelevantWorksheets()
    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, wsCnt As Integer
    Dim lr As Long, monRow As Long, expRow As Long
    Dim rng As Range, cRow As Range, fillRangeRow As Range, target As Range
    Dim hasGLNum As Long
    Dim ar As Variant
    
    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
                ' for testing...don't uncomment this line
                '.Columns("A:A").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:A").Insert Shift:=xlToRight
                .Columns("A:A").NumberFormat = "@"
                
                ' set working range
                lr = .Cells(.Rows.Count, "C").End(xlUp).row
                Set rng = .Range("C2:O" & lr)
                
                ' add sheet name
                .Range("A2:A" & lr).Value = "'" & numericPart
                
                ' loop through and sum expense
                For Each cRow In ws.Range("C2:C" & 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
                    
                    ' 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, 4), ws.Cells(expRow, 15))
                        fillRangeRow.Formula = "=SUM(D" & monRow & ":D" & 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
                
                ' delete contingent
                For i = ws.UsedRange.Rows.Count To 1 Step -1
                    If InStr(1, ws.Range("C" & 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("C" & i).Value, "Expense", vbTextCompare) > 0 And ws.Range("B" & i).Value <> "" Then
                        Set fillRangeRow = ws.Range(ws.Cells(i, 1), ws.Cells(i, 15))
                        Set rng = mstTemp.Cells(lr, 1)
                        Set rng = rng.Resize(1, fillRangeRow.Columns.Count)
                        rng.Value = fillRangeRow.Value
    
                        lr = lr + 1
                    End If
                Next
            End With

            ' count ws success
            wsCnt = wsCnt + 1
        End If
        numericPart = ""
    Next
    
    ' clean up msttemp
    With mstTemp
        .Cells(, 3).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:N3").Value = Array("Sheet", "GL Account", "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("C:N").HorizontalAlignment = xlRight
        .Columns("C:N").AutoFit
        .Range("C:N").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 1
Solution
Hhahahaha Wow this is unbelievable! Did you get this good by just using this forum and online research and studying?

So that i can learn: What would the code to be to delete lines in the master that have 0 for Jan to Dec like the ones below and where would you suggest I enter that code?

1706897962276.png


Oh and is it possible to have like a completed message pop up. I think i've seen that before.
 
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
516
Micron
M
A
  • Solved
Make vba macro functional for all workbooks
Replies
8
Views
201
abramo
A
Q
  • Solved
How to stop InputBox from looping after input?
Replies
7
Views
353
qplsn9
Q
B
  • Question
Pivot table: iterating through each item takes forever
Replies
2
Views
148
RoryA
RoryA
franklin_m
  • Question
VBA Search row for instances of pattern in two adjacent cells
Replies
3
Views
252
franklin_m
franklin_m

Forum statistics

Threads
1,217,364
Messages
6,136,117
Members
449,993
Latest member
Sphere2215

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