![](/img/trans.png)
[英]I need to create new sheets based on unique names found in column A. Current Code generates excess data in certain sheets
[英]Create new sheets based on dynamic values in certain column
例如,给定 B 列中的一系列值 - 我们只有从B4
到B5
的 2 个值,其中12
在B4
中, 99
在B5
中。
对于 B 列中的每个值(我们称之为product code )(这里是12
和99
),我想:
技巧:值的数量是动态的,它肯定以B4
开头,但可能以 B 列中的任何值结尾
对于代码,我认为逻辑应该是:
##(1) get the range of values in column B starting from B4 (which is dynamic)
##(2) loop through all values in the column, create a sheet for each and change its name to the product
但是,我不确定
(1) 如何获取列中的值并将它们存储在集合中以方便第二步?
(2) 也许我可以在第二步做类似下面的事情:
Dim SourceSheet As Object
Set SourceSheet = ActiveSheet
SourceSheet.Copy After:=SourceSheet
Dim NewSheet As Object
Set NewSheet = ThisWorkbook.Sheets(SourceSheet.Index + 1)
On Error GoTo ERR_RENAME
NewSheet.Name = "InputName"
On Error GoTo 0
但是这里我们需要对我们在步骤1中生成的集合中的每一个item都做,并根据item值(集合中的商品编码)来命名。
任何帮助将不胜感激,在此先感谢。
Option Explicit
Sub CreateOrders()
' Define constants.
Const PROC_TITLE As String = "Create Orders"
Const DATA_SHEET_NAME As String = "Sheet1" ' adjust!
Const DATA_FIRST_CELL As String = "B4"
Const SOURCE_SHEET_NAME As String = "Order"
Const DST_CELL As String = "C2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the data range.
Dim ws As Worksheet: Set ws = wb.Sheets(DATA_SHEET_NAME)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range, rCount As Long
With ws.Range(DATA_FIRST_CELL)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No product IDs found.", vbExclamation, PROC_TITLE
Exit Sub
End If
rCount = lCell.Row - .Row + 1
Set rg = .Resize(rCount)
End With
' Write the values from the data range to an array.
Dim Data() As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, rString As String
For r = 1 To rCount
rString = CStr(Data(r, 1))
If Len(rString) > 0 Then ' not blank
dict(rString) = Empty
End If
Next r
If dict.Count = 0 Then
MsgBox "The product ID column is blank.", vbExclamation, PROC_TITLE
Exit Sub
End If
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Sheets(SOURCE_SHEET_NAME)
' Create orders.
Application.ScreenUpdating = False
Dim dsh As Object, rKey As Variant, oCount As Long, ErrNum As Long
For Each rKey In dict.Keys
' Check if the order exists.
On Error Resume Next ' defer error trapping
Set dsh = wb.Sheets(rKey)
On Error GoTo 0 ' turn off error trapping
' Create order.
If dsh Is Nothing Then ' the order doesn't exist
sws.Copy After:=wb.Sheets(wb.Sheets.Count) ' copy as last sheet
Set dsh = wb.Sheets(wb.Sheets.Count) ' reference the new last sheet
On Error Resume Next ' defer error trapping
dsh.Name = rKey ' rename
ErrNum = Err.Number
On Error GoTo 0 ' turn off error trapping
If ErrNum = 0 Then ' valid sheet name
dsh.Range(DST_CELL).Value = rKey ' write to the cell
oCount = oCount + 1
Else ' invalid sheet name
Application.DisplayAlerts = False ' delete without confirmation
dsh.Delete
Application.DisplayAlerts = True
End If
'Else ' the order exists; do nothing
End If
Set dsh = Nothing ' reset for the next iteration
Next rKey
Application.ScreenUpdating = True
' Inform.
Select Case oCount
Case 0: MsgBox "No new orders.", vbExclamation, PROC_TITLE
Case 1: MsgBox "One new order created.", vbInformation, PROC_TITLE
Case Else: MsgBox oCount & " new orders created.", _
vbInformation, PROC_TITLE
End Select
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.