我尝试将一个数字从一张工作表中的一个列表复制到特定单元格中新创建的工作表。代码首先检查是否已经存在具有此名称的工作表,如果不存在,则创建一个新工作表,然后将其添加并粘贴到另一个工作表中的表格中。完成此操作后,我还希望从列表中填写一个数字,但我无法像第一个那样使用 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
结束子`
答案 0 :(得分:0)
default
答案 1 :(得分:0)
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
这两个代码现在都可以使用。他们浏览一个列表并为列表中的每个单元格创建一个新工作表。