Copy Excel sheet multiple times with a column condition and rename it

[sofas]

Hi.I have this code to copy a specific sheet provided that the number of values in the H column and rename it with the same value, but it is very slow because I have to scrape all the sheets and recreate them again, which is about 400 sheets, is there a way to check the existence of the sheet name, override it, and copy the rest to be faster, or any other way.

Sub TEST()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
On Error GoTo Errorhandling
Set ST = Sheet1
lr = ST.Range("h" & Rows.Count).End(xlUp).Row
Sheet2.Visible = True
Set rng = Range("H2:H" & lr)
Application.ScreenUpdating = True
For Each ws In Worksheets
    If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
Next

For Each cell In rng
    If cell <> "" Then
     Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = cell
        Range("i19").Value = ActiveSheet.Name
       Sheet2.Visible = False
    End If
Next cell
Errorhandling:
Sheet1.Activate
Sheet1.Range("b2:b" & lr).ClearContents
Sheet1.Range("b2").Select
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
ActiveCell.Offset(1, 0).Select
Application.ScreenUpdating = False
End If
Next ws
End Sub

 

[HaHoBe]

Hi sofas,

not sure if this is considerably faster but give the code a try on a copy of the original workbook:

Public Sub MrE_1230349_1703219()
' https://www.mrexcel.com/board/threads/copy-excel-sheet-multiple-times-with-a-column-condition-and-rename-it.1230349/

Dim ws As Worksheet
Dim wsOne As Worksheet
Dim arr As Variant
Dim varRet As Variant
Dim lngArr As Long
Dim lr As Long
Dim strNoAction As String
Dim rngCell As Range

strNoAction = "Vehicle,Data,Sample"
Set wsOne = Sheet1
lr = wsOne.Range("H" & wsOne.Rows.Count).End(xlUp).Row
arr = wsOne.Range("H2:H" & lr).Value

Application.ScreenUpdating = True

'delete not mentioned sheets
For Each ws In Worksheets
  If InStr(1, strNoAction, ws.Name) = 0 Then
    varRet = Application.Match(ws.Name, arr, 0)
    If IsError(varRet) Then
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
    End If
  End If
Next ws

'append new sheets if needed
For lngArr = LBound(arr) To UBound(arr)
  If Len(Trim(arr(lngArr, 1))) > 0 Then
    If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then
      Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = arr(lngArr, 1)
      Range("i19").Value = arr(lngArr, 1)
    End If
  End If
Next lngArr

Sheet2.Visible = False
With Sheet1
  .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents
  Set rngCell = .Range("B2")
End With

'make hyperlinks on Sheet Data
For Each ws In ActiveWorkbook.Worksheets
  If InStr(1, strNoAction, ws.Name) = 0 Then
    rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
    Set rngCell = rngCell.Offset(1)
  End If
Next ws

Set rngCell = Nothing
Set wsOne = Nothing

Application.ScreenUpdating = False

End Sub

Ciao,
Holger

 

[sofas]

Hi sofas,

not sure if this is considerably faster but give the code a try on a copy of the original workbook:

Public Sub MrE_1230349_1703219()
' https://www.mrexcel.com/board/threads/copy-excel-sheet-multiple-times-with-a-column-condition-and-rename-it.1230349/

Dim ws As Worksheet
Dim wsOne As Worksheet
Dim arr As Variant
Dim varRet As Variant
Dim lngArr As Long
Dim lr As Long
Dim strNoAction As String
Dim rngCell As Range

strNoAction = "Vehicle,Data,Sample"
Set wsOne = Sheet1
lr = wsOne.Range("H" & wsOne.Rows.Count).End(xlUp).Row
arr = wsOne.Range("H2:H" & lr).Value

Application.ScreenUpdating = True

'delete not mentioned sheets
For Each ws In Worksheets
  If InStr(1, strNoAction, ws.Name) = 0 Then
    varRet = Application.Match(ws.Name, arr, 0)
    If IsError(varRet) Then
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
    End If
  End If
Next ws

'append new sheets if needed
For lngArr = LBound(arr) To UBound(arr)
  If Len(Trim(arr(lngArr, 1))) > 0 Then
    If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then
      Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = arr(lngArr, 1)
      Range("i19").Value = arr(lngArr, 1)
    End If
  End If
Next lngArr

Sheet2.Visible = False
With Sheet1
  .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents
  Set rngCell = .Range("B2")
End With

'make hyperlinks on Sheet Data
For Each ws In ActiveWorkbook.Worksheets
  If InStr(1, strNoAction, ws.Name) = 0 Then
    rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
    Set rngCell = rngCell.Offset(1)
  End If
Next ws

Set rngCell = Nothing
Set wsOne = Nothing

Application.ScreenUpdating = False

End Sub

Ciao,
Holger

Always brilliant thank you very much

 

[johnnyL]

Why is application.screenupdating = True when script is running & set to False after the script running?

 

[sofas]

Why is application.screenupdating = True when script is running & set to False after the script running?

Yes, as far as my weak experience is supposed to be in the end, True. I noticed it when I rearranged the code again and changed it

 

[HaHoBe]

Hi johnnyL,

I must admit I totally missed that, thanks for pointing it out.

Holger