For Each 两次还是？

Question

我尝试将一个数字从一张工作表中的一个列表复制到特定单元格中新创建的工作表。代码首先检查是否已经存在具有此名称的工作表，如果不存在，则创建一个新工作表，然后将其添加并粘贴到另一个工作表中的表格中。完成此操作后，我还希望从列表中填写一个数字，但我无法像第一个那样使用 FOR EACH。我真的不知道我该怎么办？我试图在每个新工作表中写入 inum。

 `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

结束子`

Answer 1

从列表创建工作表

default

Answer 2

    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

或

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 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

这两个代码现在都可以使用。他们浏览一个列表并为列表中的每个单元格创建一个新工作表。