我有两个表，一个是用于测试的脚本，另一个是需要测试的用户名和脚本编号。我想为每个用户创建一个表，只包含他们需要测试的脚本。下面的代码正确地创建了制表符，但只在脚本1上为每个用户复制。
表脚本:
步骤名称指令添加联系人 登录系统
这可能不是最有效的方法，但我认为最简单:
Sub test()
Dim wb As Workbook, wsScripts As Worksheet, wsUsers As Worksheet
Dim rngScripts As Range, rngUsers As Range, rw As Range, usr, m
Dim rngHeaders As Range, c As Range
Set wb = ThisWorkbook
Set wsScripts = wb.Worksheets("Scripts")
Set wsUsers = wb.Worksheets("Users")
Set rngHeaders = wsScripts.Range("A1:E1") 'headers for new sheets
Set rngScripts = wsScripts.Range("A2:E" & wsScripts.Cells(Rows.Count, "A").End(xlUp).Row)
Set rngUsers = wsUsers.Range("A2:A" & wsUsers.Cells(Rows.Count, "A").End(xlUp).Row)
For Each rw In rngScripts.Rows 'loop over the script rows
For Each c In rngUsers.Cells 'loop over the users
m = Application.Match(rw.Cells(1).Value, c.EntireRow, 0)
If Not IsError(m) Then 'user has this script assigned
With GetWorksheet(wb, c.Value, rngHeaders)
'copy script row to next empty cell
rw.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
End If
Next c
Next rw
End Sub
'Return the worksheet named `wsName` from workbook `wb`
'If the sheet doesn't exist then create it, and optionally copy
' headers from `rngHeaders` to the new sheet
Function GetWorksheet(wb As Workbook, wsName As String, _
Optional rngHeaders As Range = Nothing) As Worksheet
On Error Resume Next 'ignore error if no sheet with this name
Set GetWorksheet = wb.Worksheets(wsName)
On Error GoTo 0 'stop ignoring errors
If GetWorksheet Is Nothing Then
Set GetWorksheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
'copy headers if provided
If Not rngHeaders Is Nothing Then rngHeaders.Copy GetWorksheet.Range("A1")
GetWorksheet.Name = wsName 'name the new sheet
End If
End Function
导出数据到单独的工作表
- 此代码旨在将数据从源工作表导出到多个目标工作表，其中每个目标工作表对应一个唯一的用户，由查找工作表中的数据确定。
代码
Sub ExportByUsers()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Store the data from the lookup worksheet in an array.
Dim lws As Worksheet: Set lws = wb.Sheets("Users")
Dim lrg As Range, lrCount As Long, lcCount As Long
With lws.UsedRange
lrCount = .Rows.Count - 1 ' exclude headers
lcCount = .Columns.Count
If lrCount = 0 Then Exit Sub ' no data
Set lrg = .Resize(lrCount).Offset(1) ' exclude headers
End With
Dim lData(): lData = lrg.Value
' Store the unique users from the first column in a dictionary as a key,
' and store the script numbers in same row in a collection, in the item
' associated with each key.
Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
lDict.CompareMode = vbTextCompare
Dim lr As Long, lc As Long, lStr As String
For lr = 1 To lrCount
lStr = lData(lr, 1)
If Len(lStr) > 0 Then ' is not blank
If Not lDict.Exists(lStr) Then Set lDict(lStr) = New Collection
For lc = 2 To lcCount
If VarType(lData(lr, lc)) = vbDouble Then ' is a number
lDict(lStr).Add lData(lr, lc)
'Else ' is not a number; do nothing
End If
Next lc
'Else ' is blank
End If
Next lr
' Store the data from the 1st column of the source worksheet in an array.
Dim sws As Worksheet: Set sws = wb.Sheets("Scripts")
Dim srg As Range, shrg As Range, srCount As Long, scCount As Long
With sws.UsedRange
srCount = .Rows.Count - 1
scCount = .Columns.Count
Set shrg = .Rows(1)
Set srg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim sData(): sData = srg.Columns(1).Value
' Store the unique script numbers from the array in a dictionary as a key,
' and store the row ranges of the numbers in a unioned range object,
' in the item associated with each key.
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sVal, sr As Long
For sr = 1 To srCount
sVal = sData(sr, 1)
If VarType(sVal) = vbDouble Then ' is a number
If Not sDict.Exists(sVal) Then
Set sDict(sVal) = srg.Rows(sr)
Else
Set sDict(sVal) = Union(sDict(sVal), srg.Rows(sr))
End If
'Else ' is not a number; do nothing
End If
Next sr
' Create a copy of the source worksheet to be used as a template
' i.e. to be repeatedly copied for each user.
sws.Copy after:=wb.Sheets(wb.Sheets.Count)
Dim tws As Worksheet: Set tws = wb.Sheets(wb.Sheets.Count)
With tws.UsedRange
.Resize(.Rows.Count - 1).Offset(1).Clear ' clear all except headers
End With
' For each key in the lookup dictionary, create a copy
' of the template worksheet, the destination worksheet,
' and copy the corresponding ranges to it.
Application.ScreenUpdating = False
Dim dsh As Object, dws As Worksheet, surg As Range, drg As Range
Dim lKey, lItem
For Each lKey In lDict.Keys
' Create a copy of the template worksheet.
On Error Resume Next
Set dsh = wb.Sheets(CStr(lKey))
On Error GoTo 0
If Not dsh Is Nothing Then
Application.DisplayAlerts = False ' delete without confirmation
dsh.Delete
Application.DisplayAlerts = True
Set dsh = Nothing ' reset for the next iteration
End If
tws.Copy after:=wb.Sheets(wb.Sheets.Count)
Set dws = wb.Sheets(wb.Sheets.Count)
dws.Name = lKey
Set drg = dws.UsedRange.Rows(1).Offset(1)
' Combine the ranges in a unioned range.
For Each lItem In lDict(lKey)
If sDict.Exists(lItem) Then
If surg Is Nothing Then
Set surg = sDict(lItem)
Else
Set surg = Union(surg, sDict(lItem))
End If
End If
Next lItem
' Copy the unioned range.
If Not surg Is Nothing Then
surg.Copy drg
Set surg = Nothing ' reset for the next iteration
End If
Next lKey
' Delete the template worksheet.
Application.DisplayAlerts = False
tws.Delete ' delete without confirmation
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' Inform.
MsgBox "Single-user worksheets created.", vbInformation
End Sub