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?

 

[skillilea]

try this

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

 

[skillilea]

try this

Sub CopySheetNames()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1:A200").Value = ws.Name
    Next
End Sub

 

[LearnVBA83]

try this

Sub CopySheetNames()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1:A200").Value = ws.Name
    Next
End Sub

Shut the front door! Are you serious? Wow you guys have super powers! Thank you!

 

[skillilea]

Glad to help

 

[LearnVBA83]

try this

Sub CopySheetNames()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A1:A200").Value = ws.Name
    Next
End Sub

Now can i challenge you one more time? How can i make this macro only loop through the worksheets that have a 6 digit number in the name and do this same copy paste. Also some of the 6 digit numbers have leading zeros like 000826 so i'd want to capture all 6 of those in the copy paste! Is that possible?

 

[skillilea]

test it please

Sub CopySheetNamesWith6DigitNumbers()
    Dim ws As Worksheet
    Dim nameParts() As String
    Dim i As Integer
    Dim numericPart As String
    
    For Each ws In ThisWorkbook.Worksheets
        nameParts = Split(ws.Name, "0123456789")
        
        For i = 0 To UBound(nameParts)
            If IsNumeric(nameParts(i)) And Len(nameParts(i)) = 6 Then
                ws.Range("A1:A200").Value = ws.Name
                Exit For
            End If
        Next i
    Next ws
End Sub

 

[LearnVBA83]

Wow you're awesome! That is super close. The only thing i noticed were the ones with leading 0's like 008169 it only pasted 8169 and i need 008169. Also, it skipped the ones like 296135 - GSO Ramp. I need it to pick any up that have a 6 digit number and only paste the 6 digit number. I'm not 100% but I think the 6 digit number would always be first in the name.

 

[skillilea]

This is checking to make sure the number part is exactly six digits

test it

Sub CopySheetNamesWith6DigitNumbers()
    Dim ws As Worksheet
    Dim regex As Object
    Dim match As Object
    
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\b\d{6}\b"
    
    For Each ws In ThisWorkbook.Worksheets
        If regex.Test(ws.Name) Then
            ws.Range("A1:A200").Value = ws.Name
        ElseIf Len(ws.Name) = 6 And IsNumeric(ws.Name) Then
            ws.Range("A1:A200").Value = ws.Name
        End If
    Next
End Sub

 

[LearnVBA83]

That code picked up the worksheet that had six digit number and words, but i pasted the whole name and not just the six digits. Also the worksheet with leading zeros still didn't pick up the zeros. It's close to being there thought! This is amazing.