VBA Question Sheet Creation

[nburaq]

Hi Gents,
I am quite new to VBA and still busy with improving my codes. I have simple sheet called movies and in the sheet I try to create sheet based on the value in the sheet. However, if the sheet already exists then it will not create any new sheet. Thanks for your lep and comments! Here is the simple sheet and code as well;

Movies of 2022
ID	Name	Date	Length
1​	Avatar	22/01/2001​	25​
2​	Ede	16/03/2004​	130​
3​	Hura	09/09/2012​	180​
4​	Lola	25/08/2012​	143​
5​	Storm	14/02/1997​	160​
6​	Horas	15/06/1998​	100​
7​	Soras	14/02/1996​	90​
8​	Life	14/02/1997​	75​
9​	Terminator	03/02/2006​	20​
10​	Panda	12/12/2012​	30​
11​	Gravitiy	12/12/2013​	45​

Sub CopyLoop()

    Dim FilmLength As Integer
    Dim FilmRating As String
    Dim Wb As Workbook
    Dim Ws As Worksheet
      
    Set Wb = ActiveWorkbook

    Worksheets("Movies").Activate
    Range("A3").Select

    Do Until ActiveCell.Value = ""
    
        FilmLength = ActiveCell.Offset(0, 3).Value
        
        If FilmLength < 100 Then
            FilmRating = "Short"
        ElseIf FilmLength < 150 Then
            FilmRating = "Medium"
        Else
            FilmRating = "Long"
        End If
        
        Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
        
        For Each Ws In Wb.Worksheets
    
        If Ws.Name = FilmRating Then
               Worksheets(FilmRating).Activate
        Else
               Sheets.Add.Name = FilmRating
        End If
        Next Ws
        
        ActiveCell.PasteSpecial
        ActiveCell.Offset(1, 0).Select
        
        Worksheets("Movies").Activate
        ActiveCell.Offset(1, 0).Select
        
                     
    Loop


End Sub

Debugging occures at line : Sheets.add,name=filmrating

 

[HaHoBe]

Hi nburag,

you should avoid looping through the sheets of the workbook on every single cell you are processing.

Please try

Sub CopyLoop_re()
'https://www.mrexcel.com/board/threads/vba-question-sheet-creation.1219085/

  Dim FilmRating As String
  Dim Ws As Worksheet
  Dim lngCounter As Long
    
  Const clngCol2Copy As Long = 4                                    'Columns to copy over
    
  Set Ws = ActiveWorkbook.Worksheets("Movies")                      'set object to worksheet to loop on

  With Ws
    For lngCounter = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row    'start is row 3,
                                                                    'last is the last filled cell in Column A
      With .Cells(lngCounter, "A")
        If .Value <> "" Then                                        'check if Column A has a value
          Select Case .Offset(0, clngCol2Copy - 1).Value            'go for the filmlenth for the sheetname
            Case Is < 100
              FilmRating = "Short"
            Case Is < 150
              FilmRating = "Medium"
            Case Else
              FilmRating = "Long"
          End Select
          If Not Evaluate("ISREF('" & FilmRating & "'!A1)") Then    'check if the worksheet does not exist then add and name it
            Sheets.Add.Name = FilmRating
            'add Headers
            Worksheets(FilmRating).Range("A1").Resize(1, clngCol2Copy).Value = Ws.Range("A2").Resize(1, clngCol2Copy).Value
          End If
          'copy over to the next available row
          Worksheets(FilmRating).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, clngCol2Copy).Value = .Resize(1, clngCol2Copy).Value
        End If
      End With
    Next lngCounter
  End With

  Set Ws = Nothing
End Sub

Ciao,
Holger

 

[nburaq]

Hi nburag,

you should avoid looping through the sheets of the workbook on every single cell you are processing.

Please try

Sub CopyLoop_re()
'https://www.mrexcel.com/board/threads/vba-question-sheet-creation.1219085/

  Dim FilmRating As String
  Dim Ws As Worksheet
  Dim lngCounter As Long
   
  Const clngCol2Copy As Long = 4                                    'Columns to copy over
   
  Set Ws = ActiveWorkbook.Worksheets("Movies")                      'set object to worksheet to loop on

  With Ws
    For lngCounter = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row    'start is row 3,
                                                                    'last is the last filled cell in Column A
      With .Cells(lngCounter, "A")
        If .Value <> "" Then                                        'check if Column A has a value
          Select Case .Offset(0, clngCol2Copy - 1).Value            'go for the filmlenth for the sheetname
            Case Is < 100
              FilmRating = "Short"
            Case Is < 150
              FilmRating = "Medium"
            Case Else
              FilmRating = "Long"
          End Select
          If Not Evaluate("ISREF('" & FilmRating & "'!A1)") Then    'check if the worksheet does not exist then add and name it
            Sheets.Add.Name = FilmRating
            'add Headers
            Worksheets(FilmRating).Range("A1").Resize(1, clngCol2Copy).Value = Ws.Range("A2").Resize(1, clngCol2Copy).Value
          End If
          'copy over to the next available row
          Worksheets(FilmRating).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, clngCol2Copy).Value = .Resize(1, clngCol2Copy).Value
        End If
      End With
    Next lngCounter
  End With

  Set Ws = Nothing
End Sub

Ciao,
Holger

Thanks my friend it works perfectly!, I had another approach by creating required worksheets by myself but this time in copy processing it copies values with empty rows i could not figured out why hre is alternative code ;

Sub CopyLoop()

    Dim FilmLength As Integer
    Dim FilmRating As String
    Dim i, j As Integer

    Worksheets("Movies").Activate
    Range("A3").Select
    i = 3
    j = 1
    
    Do Until IsEmpty(Cells(i, 1))
    
        FilmLength = Cells(i, 4).Value
        
        If FilmLength < 100 Then
            FilmRating = "Short"
        ElseIf FilmLength < 150 Then
            FilmRating = "Medium"
        Else
            FilmRating = "Long"
        End If
        
        Range(Cells(i, 1), Cells(i, 4)).Copy Worksheets(FilmRating).Cells(j, 1)
        i = i + 1
        j = j + 1
        Worksheets("Movies").Cells(i, 1).Select
    
    Loop


End Sub

here is output;

1​	Avatar	22/01/2001​	25​
7​	Soras	14/02/1996​	90​
8​	Life	14/02/1997​	75​
9​	Terminator	03/02/2006​	20​
10​	Panda	12/12/2012​	30​
11​	Gravitiy	12/12/2013​	45​

 

[HaHoBe]

Hi nburag,,

you have one value for the rows to process in Sheet Movies and one for the row to be copied to. And that row to copy to is used for any sheet. You could work with three different counters there but I think the approach to check the last fillled cell in Column A and offset by one row for the target sheet is a little more effective than mingling with different counters.

Ciao,
Holger