For Each two times or?

Question

I try to get a number copied from one list in one sheet to a new created sheet in specific cell. The code first check if there already exist a sheet with this name, if not it creates a new sheet and then add it and paste in a table from another sheet. After this is done I also want a number to be filled in from the list but I dont get it to work with FOR EACH as i did with first one. I really don't know how i shall do it? Im trying to get the inum to be written in each new sheet.

 `Sub Sample()
Dim ws As Worksheet
Dim Row As Long
Dim inu As Long
Dim i As Long

'~~> Set this to the relevant worksheet
Set ws = Sheets("Röd")
Set wsi = Sheets("Röd")

With ws
    '~~> Find last row in Column A
    Row = .Range("A" & .Rows.Count).End(xlUp).Row
With wsi
    inu = .Range("B" & .Rows.Count).End(xlUp).Row
    
    '~~> Loop through the range
    For i = 3 To Row
        '~~> Check if cell is not empty
        If Len(Trim(.Range("A" & i).Value2)) <> 0 Then
            '~~> Whatever this fuction does. I am guessing it
            '~~> checks if the sheet already doesn't exist
            If SheetCheck(.Range("A" & i)) = False Then
                With ThisWorkbook
                    '~~> Add the sheet
                    .Sheets.Add After:=.Sheets(.Sheets.Count)
                    '~~> Color the tab
                    .Sheets(.Sheets.Count).Tab.Color = RGB(255, 0, 0)
                    '~~> Name the tab
                    .Sheets(.Sheets.Count).Name = Left(ws.Range("A" & i).Value2, 30)
                    Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
                    .Sheets(.Sheets.Count).Range("B4").Value = ws.Range("A" & i).Value
                    Columns("A:B").AutoFit
                    Rows("1:25").AutoFit
                        For j = 3 To inu
                            'If Len(Trim(Range("B" & inu).Value2)) <> 0 Then
                                Sheets(Sheets.Count).Range("B3").Value2 = wsi.Range("B" & j).Value2
                            'End If
                        Next j
                    End With
                End If
            End If
        Next i
    End With
End With

End Sub`

I showed you how to find the last row using `xlup` in your last question. You are still using `xldown`? You may want to see [THIS](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba/11169920#11169920) I also showed you a better way to do what you doing but seems like you have ignored that too :D — Siddharth Rout, Jan 08 '21 at 09:17
I just want to see if my code can work. I don't say my code is the best at all, im new with this and are still trying to understand alot! But can i use same principal you wrote in your code? — André Larsson, Jan 08 '21 at 09:31
With your code @SiddharthRout i still dont get the right number in new created B3. The code apply the last number in the list to all sheet. Every sheet shall have a specific number according to the list. See code above. — André Larsson, Jan 08 '21 at 10:00
I think you need to spend some time understanding what the code does. — Siddharth Rout, Jan 08 '21 at 10:01
As a quick fix, Instead of the second `For Next` loop you could use `Sheets(Sheets.Count).Range("B3").Value = ws.Range("B" & i).Value` or `Sheets(Sheets.Count).Range("B3").Value = ws.Range("A" & i).Offset(, 1).Value`, or `Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value` instead of the previous second `For Each Next` loop. — VBasic2008, Jan 08 '21 at 12:18

score 0 · Accepted Answer · answered Jan 08 '21 at 12:04

Create Worksheets from List

Option Explicit

Sub createWorksheets()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    Dim MyRange As Range
    With wb.Worksheets("Röd").Range("A3")
        Set MyRange = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
            .End(xlUp).Row - .Row + 1)
    End With
    
    Application.ScreenUpdating = False
    
    Dim MyCell As Range
    For Each MyCell In MyRange.Cells
        If Len(MyCell) > 0 Then
            If Not SheetCheck(wb, MyCell.Value) Then
                With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                    ' Data
                    wb.Worksheets("Utredningsmall").Range("A1:B22").Copy _
                        Destination:=.Range("A1")
                    .Range("B3").Value = MyCell.Offset(, 1).Value
                    .Range("B4").Value = MyCell.Value
                    .Name = Left(MyCell.Value, 30)
                    ' Formats
                    .Tab.Color = RGB(255, 0, 0)
                    .Columns("A:B").AutoFit
                    .Rows("1:25").AutoFit
                End With
            End If
        End If
    Next MyCell

    Application.ScreenUpdating = True

End Sub

Function SheetCheck( _
    wb As Workbook, _
    ByVal SheetName As String) _
As Boolean
    On Error Resume Next
    Dim sh As Object: Set sh = wb.Sheets(SheetName)
    On Error GoTo 0
    SheetCheck = Not sh Is Nothing
End Function

Aaa, I can use offset to set the i number in B3! Thanks! – André Larsson Jan 08 '21 at 12:29 — André Larsson, Jan 08 '21 at 12:29

score 0 · Answer 2 · answered Jan 08 '21 at 13:44

    Sub Röd()
    Dim MyCell As Range, MyRange As Range
    Dim ws As Worksheets
    Dim inum As Range, Myinum As Range
    
    
    

    'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down

    Set MyRange = Sheets("Röd").Range("A3")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    Application.DisplayAlerts = False

    For Each MyCell In MyRange
         If SheetCheck(MyCell) = False And MyCell <> "" Then
            Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
            Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
            Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
            Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
            Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
            Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
            Columns("A:B").AutoFit
            Rows("1:25").AutoFit
            
        End If
    Next

    Application.DisplayAlerts = True
    
End Sub

OR

Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range




'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down

Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

Application.DisplayAlerts = False

For Each MyCell In MyRange
     If SheetCheck(MyCell) = False And MyCell <> "" Then
        Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
        Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
        Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
        Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
        Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
        Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
        Columns("A:B").AutoFit
        Rows("1:25").AutoFit
        
    End If
Next

Application.DisplayAlerts = True
End Sub

Function:

    Function SheetCheck(MyCell As Range) As Boolean

Dim ws As Worksheet

SheetCheck = False
 
For Each ws In ThisWorkbook.Worksheets
 
    If ws.Name = Left(MyCell.Value, 30) Then
    
        SheetCheck = True
        
    End If
 
Next
 
End Function

Both these codes works now. They go through a list and create a new sheet for each cell in the list.

For Each two times or?

2 Answers2

Create Worksheets from List