Option Explicit
'David McRitchie
' http://www.mvps.org/dmcritchie/excel/code/addsheets.txt
' may have been mentioned in...
' http://www.mvps.org/dmcritchie/excel/buildtoc2.htm
' http://www.mvps.org/dmcritchie/excel/mailmerg.htmOption Explicit

Sub repeat_BxN_Col4()
   repeat_BxN (4)
End Sub

Sub repeat_BxN(Optional ColB As Long)
'Repeat row x Col B value  2003-08-22 in misc
  Dim wsSource As Worksheet
  Dim wsNew As Worksheet
  Set wsSource = ActiveSheet
  Dim rng As Range, rng2 As Range
  Dim vRows As Long, colBstr As String
  Dim i As Long
  If ColB = 0 Then
    On Error Resume Next
    ColB = InputBox("Which column has Repetition Count", _
      "Repetition", 2)
    If Err.number <> 0 Then Exit Sub
    On Error GoTo 0
  End If
  Sheets(ActiveSheet.Name).Copy _
       Before:=Sheets(ActiveSheet.Name)
  Set wsNew = ActiveSheet
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set rng = Cells.Columns(ColB) _
        .SpecialCells(xlCellTypeConstants, 1)
  Dim A As Long
  For A = rng.Areas.Count To 1 Step -1
    For i = rng.Areas(A).Count To 1 Step -1
       Set rng2 = rng.Areas(A)(i).EntireRow
       vRows = rng2.Cells(1, ColB).Value
       rng2.Cells(1, ColB).Value = 1
       If vRows > 1 Then
        rng2.Resize(rowsize:=2).Rows(2).EntireRow. _
         Resize(rowsize:=vRows - 1).Insert Shift:=xlDown
       rng2.AutoFill rng2.Resize( _
         rowsize:=vRows), xlFillCopy
       End If
    Next i
  Next A
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub


Sub BuildSheetList_example()
  Dim cRow As Long, WS As Worksheet
  cRow = 2
  Worksheets.Add.Move after:=Worksheets(1)
  On Error Resume Next
  ActiveSheet.Name = "$$Sheets"
  If Err.number <> 0 Then ActiveSheet.Name = "$$Sheets_" & _
     Format(Date + Time(), "yyyymmdd_hhmm")
  On Error GoTo 0
  Range("A:C").Clear
  Range("a1:c1").Value = Array("Sheet", "A1", "value")
  For Each WS In ActiveWorkbook.Worksheets
   '-- sheet8 (2)
   Range("A" & cRow).Formula = WS.Name
   
   '-- =HYPERLINK("#'sheet8 (2)'!A1",'sheet8 (2)'!A1)
   Cells(cRow, 2).Formula = "=HYPERLINK(""#'" & WS.Name _
     & "'!A1"",IF('" & WS.Name & _
     "'!A1="""","""",'" & WS.Name & "'!A1))"
     
   '-- ='sheet8 (2)'!A1
   Cells(cRow, 3).Formula = "=IF('" & WS.Name _
       & "'!A1="""","""",'" & WS.Name & "'!A1)"
   Cells(cRow, 4).Value = Normalize_sheetname(WS.Name)
   cRow = cRow + 1
  Next WS
  
  '-- macro will not be complete until a 4th column is added
  '-- showing  sheetname   anysheet1 (2)  as  'anysheet00001 (00002)'
  '--- and possibly   sheet one   as    sheet00000 one
  '-- so that it can be sorted nicely...
  
  '-- sort the results:
  Dim rg As Range
  Set rg = Range("a2:d" & cRow)
  rg.Sort Key1:=rg.Cells(2, 4), Order1:=xlAscending, _
     Key2:=rg.Cells(2, 1), Order2:=xlAscending, _
     Header:=xlNo, MatchCase:=False, Orientation:=xlTopToBottom
       rg.Columns("A:C").Columns.AutoFit
       
End Sub

Function Normalize_sheetname(oldstr As String) As String
 'David McRitchie, 2003-08-28
 Dim i As Long
 Dim n As String, str As String
 For i = 1 To Len(oldstr)
   If Mid(oldstr, i, 1) >= "0" And Mid(oldstr, i, 1) <= "9" Then
     n = n & Mid(oldstr, i, 1)
   Else
     If n <> "" Then
        If Len(n) <= 5 Then n = Right("00000" & n, 5)
        str = str & n
        n = ""
     End If
     str = str & Mid(oldstr, i, 1)
   End If
 Next i
 If n <> "" Then
     If Len(n) <= 5 Then n = Right("00000" & n, 5)
     str = str & n
     n = ""
 End If
 Normalize_sheetname = "'" & str
End Function