VBA Macro Loop Through worksheet

[LearnVBA83]

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?

 

[LearnVBA83]

Well done! Give me a bit

If you solve this you're a HERO!

 

[LearnVBA83]

This is the GL codes for the four expense types. I haven't seen it yet but I would assume they may not always be in the order of wages, merit, fica, benefits. I was thinking that would be the hardest part would be to make the macro find those words and put the GL code out beside those rows.

Wages	6120110
Merit	6120807
FICA	6120605
Benefits	6030610

In a perfect world the finished result would be a master template with ALL of those 6 digit worksheets pasted in the template to look like this.

Even better if you somehow had them all dump in the master template like this...

 

[skillilea]

Try this on a copy
Paste the below into a module ie. create new module in your master sheet. It needs to be an Master.XLSM file
The other sheet does not
Change your path at the top of the code

Option Explicit

Private Const GLFilePath As String = "CHANGE YOUR PATH HERE"  ' 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
    Dim numericPart As String, char As String
    Dim i 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
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    
    Set mst = ThisWorkbook.Sheets("Master")
    Set wb = Workbooks.Open(GLFilePath)
    
    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
                '.Columns("A:A").Delete Shift:=xlToLeft
                
                ' check for filter ON
                If ActiveSheet.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
                
                ' overwrite with just values
                With .UsedRange
                    .Value = .Value
                End With
            
                ' 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).EntireRow.Delete
                    End If
                Next
                
                ' copy expenses to master
                lr = mst.Cells(.Rows.Count, "A").End(xlUp).row + 1
                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 = mst.Cells(lr, 1)
                        Set rng = rng.Resize(1, fillRangeRow.Columns.Count)
                        rng.Value = fillRangeRow.Value
    
                        lr = lr + 1
                    End If
                Next
                
            End With
        End If
        numericPart = ""
    Next
    
    ' clean up mst column
    mst.Cells(, 3).EntireColumn.Delete

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[LearnVBA83]

Wow this is awesome! Some tabs appeared to work and some not so much. I wonder if I should try the dropbox route so you can just look at the file. It won't allow me to do it with my current computer but i think I can do it later on at home.

 

[skillilea]

Are all your sheets identical?

Did it just not pick up the filenames ie. the six digits.

Yep, see if you can share the file on dropbox. Don't need the master file.

 

[LearnVBA83]

So one of the big worksheets with alot of data it seems like it's deleting every line Let me try to do the add in code XLB22 again... It may not let me capture all of it. That's the thing not all sheet rows are identical. The columns should be.

 

[LearnVBA83]

Can i paste the XL2BB in pieces? Will it allow you to put it together?

 

[skillilea]

The rows don't need to be but the columns need to match for the above to work.

You can try. Or wait for dropbox

 

[LearnVBA83]

The rows don't need to be but the columns need to match for the above to work.

You can try. Or wait for dropbox

I've never used dropbox. Does it somehow tag it to you directly or is it for all the world to see?

 

[skillilea]

Yeah the idea is that you could post your file so everyone could see it and/or help you with a solution. Part of the board rules is that it has to stay public so the answers will make sense in the future.

Dropbox is an online file storage. Another example is Onedrive but access is sometimes hard for that. You can keep trying XL2BB.

You will need some kind of rules around your sheets to be able to code against them. Ie. same columns in all sheets. Some kind of uniqueness in your sheet tabs. etc