我一直在嘗試找到一種使用特定列資料創建多個作業表的方法。
如果 Col"A" 有多個重復條目，則過濾單個值使用該值名稱創建新作業表，復制所有資料并粘貼到新添加的作業表中。
我無法用文字詳細說明這件事，抱歉我的英語不好，我附上了一個示例作業簿。
其中 Sheet1 有使用 A 列的資料的代碼將創建多個作業表。您的幫助將不勝感激。
Sub CopyPartOfFilteredRange()
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Set src = ThisWorkbook.Sheets("Sheet1")
Set tgt = ThisWorkbook.Sheets("Sheet8")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:A" & lastRow)
Set copyRange = src.Range("A1:P" & lastRow)
filterRange.AutoFilter field:=1, Criteria1:="CC"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
End Sub
資料表
抄送新表
DD 新作業表
Till the last value HH
uj5u.com熱心網友回復：
請測驗下一個改編的代碼：
Sub CopyPartOfFilteredRange()
Dim src As Worksheet, tgt As Worksheet, copyRange As Range, filterRange As Range, lastRow As Long
Dim dict As Object, filterArr, i As Long
Set src = ActiveSheet ' ActiveWorkbook.Sheets("Sheet1")
lastRow = src.Range("A" & src.rows.count).End(xlUp).row
Set copyRange = src.Range("A1:P" & lastRow)
Set filterRange = src.Range("A2:A" & lastRow) 'it assumes that there are headers on the first row
filterArr = filterRange.value 'place it in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(filterArr)
If filterArr(i, 1) <> "" Then dict(filterArr(i, 1)) = 1 'extract uniques strings
Next
filterArr = dict.Keys 'unique strings to be used in filterring
'some optimization:
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For i = 0 To UBound(filterArr)
src.AutoFilterMode = False
'insert the new sheet and name it as filterr criteria, or use the existing one, if any:
On Error Resume Next
Set tgt = ActiveWorkbook.Sheets(left(filterArr(i), 31))
If err.Number = 0 Then 'if sheets already exists:
tgt.cells.Clear 'clear its content and use it
Else 'if not, insert and name it:
Set tgt = ActiveWorkbook.Sheets.Add(After:=src)
If Len(filterArr(i)) > 31 Then filterArr(i) = left(filterArr(i), 31)
tgt.Name = filterArr(i): err.Clear
End If
On Error GoTo 0
filterRange.AutoFilter field:=1, Criteria1:=filterArr(i)
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
Next i
src.AutoFilterMode = False
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "Processed " & UBound(filterArr) & "PCP Provider Names..."
End Sub
上面的代碼已更新以處理活動作業表（以及活動作業簿上的作業表）。
It needs a little optimization (`ScreenUpdating`, `EnableEvents`, `Calculation`) and check if the sheet with a specific name already exists, clearing all (in such a case) and reuse it, instead of inserting a new one.
uj5u.com熱心網友回復：
這里發生了很多事情：
- 您需要使用 A 列中的重復值命名的作業表。首先，您需要唯一值，您可以使用 Unique 函式找到這些值：https : //support.microsoft.com/en-us/office/unique-function-c5ab87fd -30a3-4ce9-9d1a-40204fb85e1e
- 您需要將這些值傳遞到一個陣列中，然后遍歷每個：https : //www.automateexcel.com/vba/loop-through-array/
- 然后您需要復制值并粘貼到每個新作業表，這可以通過自動過濾器和 usedrange 完成。
- 然后，您需要對添加或洗掉的作業表進行大量錯誤處理。
試試這個解決方案：
Sub CopyPartOfFilteredRange()
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
Dim UValues As Variant
Dim myrange As Range
Dim sht As Worksheet
Dim list As New Collection
Set sht = ThisWorkbook.Sheets(1)
On Error Resume Next
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If LastRow = 0 Then
MsgBox "Worksheet contains no data"
Application.ScreenUpdating = True
End
End If
On Error GoTo 0
Set myrange = sht.Range("A2:A" & LastRow)
On Error Resume Next
For Each Value In myrange
list.Add CStr(Value), CStr(Value) 'extract unique strings
Next
On Error GoTo 0
ReDim UValues(list.Count - 1, 0)
For i = 0 To list.Count - 1
UValues(i, 0) = list(i 1)
Next
For i = LBound(UValues) To UBound(UValues)
If Len(UValues(i, 0)) = 0 Then
GoTo Nexti
Else
On Error Resume Next
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = UValues(i, 0)
If Err.Number = "1004" Then
On Error GoTo 0
Application.DisplayAlerts = False
MsgBox "Worksheet name " & UValues(i, 0) & " already taken"
ActiveSheet.Delete
Application.DisplayAlerts = True
GoTo Nexti
Else
On Error GoTo 0
sht.AutoFilterMode = False
sht.UsedRange.AutoFilter Field:=1, Criteria1:=UValues(i, 0), VisibleDropDown:=False, Operator:=xlFilterValues
sht.UsedRange.SpecialCells(xlCellTypeVisible).Copy
With ThisWorkbook.Sheets(UValues(i, 0))
.Range("A1").PasteSpecial ''Set this to appropriate sheet number
End With
Application.CutCopyMode = False
End If
End If
Nexti:
Next i
sht.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
創建獨特的作業表
- 這將在復制源作業表并重命名之前洗掉每個可能存在的作業表。然后它將過濾它以洗掉復制的作業表中表格范圍的不需要的行（不是整個行）。
Option Explicit
Sub CopyUniqueWorksheets()
Const swsName As String = "Sheet1"
Const sCol As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' Table Range
Dim scrg As Range: Set scrg = srg.Columns(sCol) ' Column Range
Dim srCount As Long: srCount = scrg.Rows.Count
Dim dcrgAddress As String: dcrgAddress = scrg.Address(0, 0)
Dim sdrg As Range: Set sdrg = srg.Resize(srCount - 1).Offset(1) ' Data Range
Dim ddrgAddress As String: ddrgAddress = sdrg.Address(0, 0)
If srCount < 2 Then Exit Sub ' just headers or no data at all
Dim sData As Variant: sData = scrg.Value
Dim drgAddress As String: drgAddress = srg.Address(0, 0)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dKey As Variant
Dim dString As String
Dim r As Long
For r = 2 To srCount
dKey = sData(r, 1)
If Not IsError(dKey) Then
If Len(dKey) > 0 Then
dString = CStr(dKey)
If StrComp(dString, swsName, vbTextCompare) <> 0 Then
dict(dString) = Empty
End If
End If
End If
Next r
Application.ScreenUpdating = False
Dim dws As Object
Dim drg As Range ' Delete Range
Dim dcrg As Range ' Column Range
Dim ddrg As Range ' Data Range
For Each dKey In dict.Keys
' Delete possibly existing sheet.
On Error Resume Next
Set dws = wb.Sheets(dKey)
On Error GoTo 0
If Not dws Is Nothing Then ' destination sheet exists
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
'Else ' destination sheet doesn't exist
End If
' Copy source worksheet.
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
' Rename destination worksheet.
On Error Resume Next
dws.Name = dKey
If Err.Number <> 0 Then
MsgBox "'" & dKey & "' is an invalid sheet name.", vbExclamation
End If
On Error GoTo 0
' Delete rows.
Set dcrg = dws.Range(dcrgAddress)
Set ddrg = dws.Range(ddrgAddress)
dcrg.AutoFilter 1, "<>" & dKey
On Error Resume Next
Set drg = ddrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
dws.AutoFilterMode = False ' to not delete entire rows
If Not drg Is Nothing Then
drg.Delete xlShiftUp
Set drg = Nothing
End If
Set dws = Nothing
Next dKey
sws.Activate
Application.ScreenUpdating = True
MsgBox "Unique worksheets created.", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/364861.html