Forum Discussion

JoeCavasin's avatar
JoeCavasin
Brass Contributor
Jul 30, 2023
Solved

Excel VBA - Define Range of rows from known static range as start to flexible range address as end

Need help with an Excel VBA process.  Below is a screenshot of the current logic with the intended goal noted in the red box.  Can someone assist with helping me set criteria to define the range or r...
excel
Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    Mar 06, 2025

    Please test this version carefully:

    Sub CreateNewUserTab11184()
    Dim WBK As Workbook
    Dim WSH As Worksheet
    Dim RNG1 As Range
    Dim RNG2 As Range
    Dim ADR1 As String
    Dim ADR2 As String
    Dim WSN As Worksheet
    Dim ID As Long
    Dim RowStart As String
    Dim RowEnd As String
    Dim EndAddress As String
    Dim StartAddress As String
    Dim StartMonth As Date
    Dim EndMonth As Date
    Dim StartRow As String
    Dim LR As Long


'Save and close other workbooks
    For Each WBK In Application.Workbooks
        If Not (WBK Is Application.ThisWorkbook) Then
            WBK.Close SaveChanges:=True
        End If
    Next WBK
'Find New Users on Productivity Tab
    Application.ScreenUpdating = True
    Set WBK = ThisWorkbook
    Set WSH = WBK.Worksheets("User List")
    With WSH.Range("F:F")
        Set RNG1 = .Find(What:="No", LookIn:=xlValues, Lookat:=xlWhole)
        If Not RNG1 Is Nothing Then
            Do
                ADR1 = RNG1.Address
                Set RNG2 = RNG1.Offset(0, -5)
                ADR2 = RNG2.Address
                If RNG2.Value <> "" Then
                    ID = RNG2.Value
                    StartMonth = RNG1.Offset(0, 1).Value
            'Copy template to end of sheets
                    WBK.Worksheets("Template").Copy After:=WBK.Worksheets(WBK.Worksheets.Count)
                    Set WSN = WBK.Worksheets(WBK.Worksheets.Count)
            'Update ID Cell and Tab Name on new sheet
                    WSN.Range("B8").Value = ID
                    WSN.Name = CStr(ID)
            'Identify future month rows to remove
                    'WSN.Range("A11") = RowStart
                    If RNG1.Offset(0, 2).Value <> "" Then
                        EndMonth = RNG1.Offset(0, 2).Value
                        EndAddress = Cells(WorksheetFunction.Match(CLng(EndMonth), Range("A:A"), 0), 1).Address
                        RowEnd = Range(EndAddress).Row
                        WSN.Range("A11:A" & RowEnd - 1).EntireRow.Delete
                    End If
            'Identify pre-start month rows to remove
                    StartAddress = Cells(WorksheetFunction.Match(CLng(StartMonth), Range("A:A"), 0), 1).Address
                    RowStart = Range(StartAddress).Row
                    LR = Cells(Rows.Count, 1).End(xlUp).Row
                    WSN.Range("A" & RowStart + 1 & ":A" & LR).EntireRow.Delete
            'Update New Sheet Caluclation References
                    WSN.Range("B1").Formula = "=B9"
                    WSN.Range("B3").Formula = "=SUM(G9,J9,N9)"
                    WSN.Range("B5").Formula = "=Q9"
                    WSN.Range("B9").Formula = "=SUM($AL$11:$AL$33)"
                    WSN.Range("G9").Formula = "=SUM($AO$11:$AO$33)"
                    WSN.Range("J9").Formula = "=SUM($AM$11:$AM$33)"
                    WSN.Range("N9").Formula = "=SUM($AN$11:$AN$33)"
                    WSN.Range("Q9").Formula = "=SUM($AK$11:$AK$21)"
                    WSN.Range("T9").Formula = "=SUM($AI$11:$AI$33)"
                    WSN.Range("Y9").Formula = "=SUM($AH$11:$AH$33)"
                    WSN.Range("AB9").Formula = "=SUM($AJ$11:$AJ$33)"
                    WSN.Range("AH11").Formula = "=COUNTIF($B11:$AF11,""B"")"
                    WSN.Range("AI11").Formula = "=SUMPRODUCT(VALUE($AR11:$BV11))"
                    WSN.Range("AJ11").Formula = "=COUNTIF($B11:$AF11,""=""&""J"")"
                    WSN.Range("AK11").Formula = "=COUNTIF($DD11:$EH11,""=""&""1"")"
                    WSN.Range("AL11").Formula = "=COUNTIF($EJ11:$FN11,""=""&""1"")"
                    WSN.Range("AM11").Formula = "=SUM(FP11:GT11)"
                    WSN.Range("AN11").Formula = "=SUM(IB11:JF11)"
                    WSN.Range("AO11").Formula = "=SUM(GV11:HZ11)"
                    WSN.Range("AK23").Formula = "=IF(AND(SUM($DD23:$EH23)>0,SUM($AK11:$AK21)=0),0,SUM($DD23:$EH23))"
                    WSN.Range("AM23").Formula = "=IF(AND(SUM(FP23:GT23)>0,SUM(AM11:AO21)=0),0,SUM(FP23:GT23))"
                    WSN.Range("AN23").Formula = "=IF(AND(SUM(IB23:JF23)>0,SUM(AM11:AO21)=0),0,SUM(IB23:JF23))"
                    WSN.Range("AO23").Formula = "=IF(AND(SUM(GV23:HZ23)>0,SUM(AM11:AO21)=0),0,SUM(GV23:HZ23))"
                    WSN.Rows("35:36").EntireRow.Copy
                    WSN.Rows("35:36").EntireRow.PasteSpecial xlPasteValues
            'Update User List to create links to newly created user tabs
                    WSH.Hyperlinks.Add Anchor:=RNG2, Address:="", SubAddress:="'" & WSN.Name & "'!A1"
                End If
                'RNG1.Value = "Yes"
                Set RNG1 = .Find(What:="No", Lookat:=xlWhole)
                If RNG1 Is Nothing Then Exit Do
            Loop Until RNG1.Address = ADR1
        End If
    End With
    WSH.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

     

HansVogelaar's avatar
HansVogelaar
MVP
Mar 06, 2025

Please test this version carefully:

Sub CreateNewUserTab11184()
    Dim WBK As Workbook
    Dim WSH As Worksheet
    Dim RNG1 As Range
    Dim RNG2 As Range
    Dim ADR1 As String
    Dim ADR2 As String
    Dim WSN As Worksheet
    Dim ID As Long
    Dim RowStart As String
    Dim RowEnd As String
    Dim EndAddress As String
    Dim StartAddress As String
    Dim StartMonth As Date
    Dim EndMonth As Date
    Dim StartRow As String
    Dim LR As Long


'Save and close other workbooks
    For Each WBK In Application.Workbooks
        If Not (WBK Is Application.ThisWorkbook) Then
            WBK.Close SaveChanges:=True
        End If
    Next WBK
'Find New Users on Productivity Tab
    Application.ScreenUpdating = True
    Set WBK = ThisWorkbook
    Set WSH = WBK.Worksheets("User List")
    With WSH.Range("F:F")
        Set RNG1 = .Find(What:="No", LookIn:=xlValues, Lookat:=xlWhole)
        If Not RNG1 Is Nothing Then
            Do
                ADR1 = RNG1.Address
                Set RNG2 = RNG1.Offset(0, -5)
                ADR2 = RNG2.Address
                If RNG2.Value <> "" Then
                    ID = RNG2.Value
                    StartMonth = RNG1.Offset(0, 1).Value
            'Copy template to end of sheets
                    WBK.Worksheets("Template").Copy After:=WBK.Worksheets(WBK.Worksheets.Count)
                    Set WSN = WBK.Worksheets(WBK.Worksheets.Count)
            'Update ID Cell and Tab Name on new sheet
                    WSN.Range("B8").Value = ID
                    WSN.Name = CStr(ID)
            'Identify future month rows to remove
                    'WSN.Range("A11") = RowStart
                    If RNG1.Offset(0, 2).Value <> "" Then
                        EndMonth = RNG1.Offset(0, 2).Value
                        EndAddress = Cells(WorksheetFunction.Match(CLng(EndMonth), Range("A:A"), 0), 1).Address
                        RowEnd = Range(EndAddress).Row
                        WSN.Range("A11:A" & RowEnd - 1).EntireRow.Delete
                    End If
            'Identify pre-start month rows to remove
                    StartAddress = Cells(WorksheetFunction.Match(CLng(StartMonth), Range("A:A"), 0), 1).Address
                    RowStart = Range(StartAddress).Row
                    LR = Cells(Rows.Count, 1).End(xlUp).Row
                    WSN.Range("A" & RowStart + 1 & ":A" & LR).EntireRow.Delete
            'Update New Sheet Caluclation References
                    WSN.Range("B1").Formula = "=B9"
                    WSN.Range("B3").Formula = "=SUM(G9,J9,N9)"
                    WSN.Range("B5").Formula = "=Q9"
                    WSN.Range("B9").Formula = "=SUM($AL$11:$AL$33)"
                    WSN.Range("G9").Formula = "=SUM($AO$11:$AO$33)"
                    WSN.Range("J9").Formula = "=SUM($AM$11:$AM$33)"
                    WSN.Range("N9").Formula = "=SUM($AN$11:$AN$33)"
                    WSN.Range("Q9").Formula = "=SUM($AK$11:$AK$21)"
                    WSN.Range("T9").Formula = "=SUM($AI$11:$AI$33)"
                    WSN.Range("Y9").Formula = "=SUM($AH$11:$AH$33)"
                    WSN.Range("AB9").Formula = "=SUM($AJ$11:$AJ$33)"
                    WSN.Range("AH11").Formula = "=COUNTIF($B11:$AF11,""B"")"
                    WSN.Range("AI11").Formula = "=SUMPRODUCT(VALUE($AR11:$BV11))"
                    WSN.Range("AJ11").Formula = "=COUNTIF($B11:$AF11,""=""&""J"")"
                    WSN.Range("AK11").Formula = "=COUNTIF($DD11:$EH11,""=""&""1"")"
                    WSN.Range("AL11").Formula = "=COUNTIF($EJ11:$FN11,""=""&""1"")"
                    WSN.Range("AM11").Formula = "=SUM(FP11:GT11)"
                    WSN.Range("AN11").Formula = "=SUM(IB11:JF11)"
                    WSN.Range("AO11").Formula = "=SUM(GV11:HZ11)"
                    WSN.Range("AK23").Formula = "=IF(AND(SUM($DD23:$EH23)>0,SUM($AK11:$AK21)=0),0,SUM($DD23:$EH23))"
                    WSN.Range("AM23").Formula = "=IF(AND(SUM(FP23:GT23)>0,SUM(AM11:AO21)=0),0,SUM(FP23:GT23))"
                    WSN.Range("AN23").Formula = "=IF(AND(SUM(IB23:JF23)>0,SUM(AM11:AO21)=0),0,SUM(IB23:JF23))"
                    WSN.Range("AO23").Formula = "=IF(AND(SUM(GV23:HZ23)>0,SUM(AM11:AO21)=0),0,SUM(GV23:HZ23))"
                    WSN.Rows("35:36").EntireRow.Copy
                    WSN.Rows("35:36").EntireRow.PasteSpecial xlPasteValues
            'Update User List to create links to newly created user tabs
                    WSH.Hyperlinks.Add Anchor:=RNG2, Address:="", SubAddress:="'" & WSN.Name & "'!A1"
                End If
                'RNG1.Value = "Yes"
                Set RNG1 = .Find(What:="No", Lookat:=xlWhole)
                If RNG1 Is Nothing Then Exit Do
            Loop Until RNG1.Address = ADR1
        End If
    End With
    WSH.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

  • JoeCavasin's avatar
    JoeCavasin
    Brass Contributor
    Mar 12, 2025

    Tagging on to the thread for this workbook, though a different macro.  The above solution worked beautifully, btw, for the Create New user routine. 

    The new item discovered is in the remove user tab routine.    The original remove user code included looking at user list range H:H for "****-**" as a starting point, however further review and test by several users highlighted the fact users input various date formats, and using wildcard "YYYY-MM" isn't exactly the same as evaluating whether a given cell's value is a date.  My attempt below is to use the IsDate function to evaluate column H:H for any date value.  So far this attempt is not erroring, however it is also not removing the user tab with an end month populated.  what am i missing?

     

    Option Explicit
    Sub DEVRemoveUserCCCCC()
        Dim WBK As Workbook
        Dim WKS As Worksheet
        Dim RNG As Range
        Dim ADR As String
        Dim RWS As Worksheet
        Dim RID As String
        Dim eMonth As Range
        Dim sTemp As String
        Dim ToPath As String
        
        sTemp = "Deleted user tabs for the following users departing the team: "
        
    'Save and close other workbooks
        For Each WBK In Application.Workbooks
            If Not (WBK Is Application.ThisWorkbook) Then
                WBK.Close SaveChanges:=True
            End If
        Next WBK
    'Find Users leaving team from - end month denotes when user will leave
        Application.DisplayAlerts = False
        Set WBK = ThisWorkbook
        Set WKS = WBK.Worksheets("User List")
        With WKS.Range("H2:H50")
            Set eMonth = .Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole)
            If eMonth = IsDate(eMonth) Then
            ADR = eMonth.Address
                Do
                    If eMonth.Offset(0, -7).Value <> "" Then
                        RID = eMonth.Offset(0, -7).Value
                        Set RWS = ThisWorkbook.Worksheets(RID)
                        RWS.PageSetup.PrintArea = "$A$8:$AF$36"
                        sTemp = sTemp & vbCrLf & "*" & RWS.Name
                        RWS.ExportAsFixedFormat xlTypePDF, Filename:=ToPath & "EID " & RWS.Range("B8").Value & " - Final Attendance Record.pdf", IgnorePrintAreas:=False, OpenAfterPublish:=True
                        RWS.Delete
                        Range(ADR).EntireRow.Delete
                    End If
                    Set eMonth = .Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole, SearchDirection:=xlNext)
                    If eMonth Is Nothing Then Exit Do
                Loop Until IsEmpty(eMonth)
            End If
        End With
        WBK.Save
        MsgBox sTemp
    End Sub

    • HansVogelaar's avatar
      HansVogelaar
      MVP
      Mar 12, 2025

      Here is a working version, with a few improvements:

      Sub DEVRemoveUserCCCCC()
    Dim WBK As Workbook
    Dim WKS As Worksheet
    Dim RNG As Range
    Dim RWS As Worksheet
    Dim RID As String
    Dim eMonth As Range
    Dim sTemp As String
    Dim ToPath As String
    Dim r As Long
    Dim m As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ToPath = ThisWorkbook.Path
    If Right(ToPath, 1) <> Application.PathSeparator Then
        ToPath = ToPath & Application.PathSeparator
    End If

    'Save and close other workbooks
    For Each WBK In Application.Workbooks
        If Not (WBK Is ThisWorkbook) Then
            WBK.Close SaveChanges:=True
        End If
    Next WBK

    'Find Users leaving team from - end month denotes when user will leave
    Set WBK = ThisWorkbook
    Set WKS = WBK.Worksheets("User List")
    m = WKS.Range("H" & WKS.Rows.Count).End(xlUp).Row
    For r = m To 2 Step -1
        Set eMonth = WKS.Range("H" & r)
        If IsDate(eMonth.Value) And eMonth.Offset(0, -7).Value <> "" Then
            RID = eMonth.Offset(0, -7).Value
            Set RWS = ThisWorkbook.Worksheets(RID)
            RWS.PageSetup.PrintArea = "$A$8:$AF$36"
            sTemp = sTemp & vbCrLf & "* " & RWS.Name
            RWS.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=ToPath & "EID " & RWS.Range("B8").Value & " - Final Attendance Record.pdf", _
                IgnorePrintAreas:=False, OpenAfterPublish:=True
            RWS.Delete
            WKS.Range("H" & r).EntireRow.Delete
        End If
    Next r

    WBK.Save
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    If sTemp = "" Then
       sTemp = "No departing users"
    Else
       sTemp = "Deleted user tabs for the following users departing the team:" & sTemp
    End If
    MsgBox sTemp
End Sub

       

  • JoeCavasin's avatar
    JoeCavasin
    Brass Contributor
    Mar 07, 2025

    Thanks as always, Hans.  Not sure if you could determine why the routine suddenly began deleting the value in A11?  I had made some minor changes for conditional formatting but couldn't see how that would trigger the code to then blank out a specific cells value?  Not a huge deal if the root cause wasn't apparent to you, but curious all the same.  

    Also - i've looked up the new bits and don't fully understand them, but they work!  

    • HansVogelaar's avatar
      HansVogelaar
      MVP
      Mar 07, 2025

      You looked at the start month for both future months and pre-start months. For future months you have to look at the end month instead.

Resources