[英]Filter Range Copy Paste the Value and Create new Sheets
我一直在嘗試找到一種使用特定列數據創建多個工作表的方法。
如果 Col"A" 有多個重復條目，則過濾單個值使用該值名稱創建新工作表，復制所有數據並粘貼到新添加的工作表中。
我無法用語言詳細說明這件事，對不起我的英語不好，我附上了一個示例工作簿。
Sheet1 使用 Column 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
請測試下一個改編的代碼：
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.
這里發生了很多事情：
試試這個解決方案：
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
解決方案
Option Explicit
Sub CopyUniqueWorksheets()
Const ProcTitle As String = "Copy Unique Worksheets"
Dim dTime As Double: dTime = Timer ' time measuring
Debug.Print "Started '" & ProcTitle & "' at '" & Now & "'." ' log
Const swsName As String = "Sheet1"
Const sCol As Long = 1
Const dFirstCellAddress As String = "A1"
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 ' Source Range
Dim srCount As Long: srCount = srg.Rows.Count ' Source Rows Count
If srCount < 2 Then Exit Sub ' just headers or no data at all
Dim sData As Variant: sData = srg.Columns(sCol).Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dKey As Variant
Dim dString As String
Dim r As Long
' Write the unique strings to a dictionary.
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
If dict.Count = 0 Then Exit Sub ' only blanks and error values and whatnot
Erase sData
Application.ScreenUpdating = False
Dim scrg As Range ' Source Copy Range
Dim dws As Object
Dim dwsName As String
For Each dKey In dict.Keys
' Restrict to maximum allowed characters (31).
dwsName = dKey
If Len(dwsName) > 31 Then
dwsName = Left(dwsName, 31)
Debug.Print "'" & dKey & "' is too long." & vbLf _
& "'" & dwsName & "' is used in the continuation." ' log
End If
' Delete possibly existing sheet.
On Error Resume Next
Set dws = wb.Sheets(dwsName)
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
' Create a reference to a newly added (destination) worksheet.
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Rename Destination Worksheet.
On Error Resume Next
dws.Name = dwsName
If Err.Number <> 0 Then ' invalid sheet name
' log
Debug.Print "'" & dwsName & "' cannot be used as a sheet name."
'Else ' valid sheet name
End If
On Error GoTo 0
' Create a reference to the Source Copy Range.
srg.AutoFilter sCol, dKey
Set scrg = srg.SpecialCells(xlCellTypeVisible) ' headers are visible
sws.AutoFilterMode = False
' Copy the Source Copy Range to the Destination Worksheet.
scrg.Copy dws.Range(dFirstCellAddress)
' Initialize Destination Worksheet variable (reference).
Set dws = Nothing
Next dKey
sws.Activate
Application.ScreenUpdating = True
Debug.Print "It took " & Timer - dTime & " seconds." ' time measuring
Debug.Print "Ended '" & ProcTitle & "' at '" & Now & "'." ' log
MsgBox "Unique worksheets created.", vbInformation, ProcTitle
End Sub
幾乎沒有關系
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a workbook ('wb'), deletes all sheets except the ones
' whose names are in a list ('ExceptionsList').
' Remarks: At least one of the remaining sheets has to be visible.
' A very hidden sheet cannot be deleted.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteSheets()
On Error GoTo ClearError
Const ExceptionsList As String = "Sheet1"
Const Delimiter As String = "," ' tied to 'ExceptionsList'
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim sh As Object
Dim ex As Long
Dim IsFoundVisibleSheet
For ex = 0 To UBound(Exceptions)
On Error Resume Next
Set sh = Nothing
Set sh = wb.Sheets(Exceptions(ex))
On Error GoTo ClearError
If Not sh Is Nothing Then ' sheet exists
If sh.Visible = xlSheetVisible Then ' sheet is visible
IsFoundVisibleSheet = True
Exit For
'Else ' sheet is not visible
End If
'Else ' sheet doesn't exist
End If
Next ex
If Not IsFoundVisibleSheet Then Exit Sub ' no remaining visible sheets
Dim SheetNames() As String: ReDim SheetNames(1 To wb.Sheets.Count)
Dim VeryHidden() As String: ReDim VeryHidden(1 To wb.Sheets.Count)
Dim sn As Long
Dim vh As Long
Dim shName As String
For Each sh In wb.Sheets
shName = sh.Name
If IsError(Application.Match(shName, Exceptions, 0)) Then
sn = sn + 1
SheetNames(sn) = shName
If sh.Visible = xlVeryHidden Then
vh = vh + 1
VeryHidden(vh) = shName
'Else ' sheet is not very hidden
End If
'Else ' sheet found in 'Exceptions'
End If
Next sh
If sn = 0 Then Exit Sub ' no sheets to delete
ReDim Preserve SheetNames(1 To sn)
If vh > 0 Then
ReDim Preserve VeryHidden(1 To vh)
For vh = 1 To vh
wb.Sheets(VeryHidden(vh)).Visible = xlSheetVisible
Next vh
'Else ' no very hidden sheets
End If
Application.DisplayAlerts = False ' delete without confirmation
wb.Sheets(SheetNames).Delete
Application.DisplayAlerts = True
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
初始（舊）答案
這個想法是有效的，但它永遠需要 OP 的數據。
這將在復制源工作表並重命名之前刪除每個可能存在的工作表。 然后它將過濾它以刪除復制的工作表中表格范圍的不需要的行（不是整行）。
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
添加多個工作表，命名它們，並將粘貼動態范圍復制到新工作表中
[英]Add multiple sheets, name them, and copy paste dynamic range into new sheets
VBA 用於過濾的宏，從列中復制指定值並創建然后粘貼到具有該列名稱的新工作表中
[英]VBA Macro to filter, copy the specified value from a column and create then paste in a new sheet with that column name
宏根據特定的單元格值將行粘貼范圍復制到不同的工作表中
[英]Macro to copy-paste range in row to different sheets based on specific cell value
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.