时间戳

首页 > 解决方案 > 对于每个两次或？

excel - 对于每个两次或？

问题描述

我尝试将一个数字从一张表中的一个列表复制到特定单元格中新创建的表中。代码首先检查是否已经存在具有此名称的工作表，如果不存在，则创建一个新工作表，然后将其添加并粘贴到另一个工作表中的表中。完成此操作后，我还希望从列表中填写一个数字，但我没有像第一个那样让它与 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

结束子`

标签： excelvba

解决方案

从列表创建工作表

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

推荐阅读