View Single Post
 
Old 04-28-2022, 06:02 AM
p45cal's Avatar
p45cal p45cal is offline Windows 10 Office 2019
Expert
 
Join Date: Apr 2014
Posts: 956
p45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond repute
Default

Your mrexcel link is broken, it's:
Rename Worksheet based on calculated worksheets | MrExcel Message Board



try:
Code:
Sub BuildTemplateINm()
Application.ScreenUpdating = False
Dim Ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long, NweShtName As String, ALOIFOTS As Boolean

'unconditionally delete all sheets whose name begins 'TEMPLATE':
Application.DisplayAlerts = False
For Each Ws In Worksheets
  If Left(Ws.Name, 8) = "TEMPLATE" Then Ws.Delete
Next Ws
Application.DisplayAlerts = True

'Always add a new TEMPLATE sheet:
Set desWS = Sheets.Add(after:=Sheets(Sheets.Count))
With desWS
  .Name = "TEMPLATE"
  .Range("A1").Resize(, 2).Value = Array("Description", "Quantity")
End With

NweShtName = "TEMPLATE"    'the future name of this worksheet which will be built upon.
For Each Ws In Sheets
  ALOIFOTS = False    'At Least One Item Found On This Sheet
  If Left(Ws.Name, 8) <> "TEMPLATE" Then
    With Ws
      If .Range("H" & .Rows.Count).End(xlUp).Row > 12 Then
        For Each rng In .Range("H14", .Range("H" & .Rows.Count).End(xlUp))
          If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
            ALOIFOTS = True
            With desWS
              .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -6), rng)
            End With
          End If
        Next rng
      End If
      If .Range("O" & .Rows.Count).End(xlUp).Row > 12 Then
        For Each rng In .Range("O14", .Range("O" & .Rows.Count).End(xlUp))
          If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
            ALOIFOTS = True
            With desWS
              .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -6), rng)
            End With
          End If
        Next rng
      End If
    End With
  End If
  If ALOIFOTS Then NweShtName = NweShtName & "-" & Ws.Name
Next Ws
With desWS
  .Columns.AutoFit
  .Name = NweShtName
End With
Application.ScreenUpdating = True
End Sub
Reply With Quote