I have been trying to find an way to create multiple sheets using Specific Column data.
If Col"A" has multiple duplicate entries then filter single value create the new sheet using that value name, copy all the data and paste into newly added sheet.
I am unable to elaborate this thing in words and sorry for my poor English, i have attached an example workbook.
Where Sheet1 has data using Column A code will create multiple sheets. Your help will be much appreciated.
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
Data Sheet
CC New Sheet
DD New Sheet
Till the last value HH
CodePudding user response：
Please, test the next adapted code:
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
The above code has been updated to process the active sheet (and sheets on active workbook).
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.
CodePudding user response：
There is a lot going on here:
- You want sheets named with the duplicate values in column A. First, you need the unique values, which you can find using the Unique function: https://support.microsoft.com/en-us/office/unique-function-c5ab87fd-30a3-4ce9-9d1a-40204fb85e1e
- You need to pass those values into an array and then loop through each: https://www.automateexcel.com/vba/loop-through-array/
- Then you need to copy the values and paste to each new sheet which can be done with the autofilter and usedrange.
- Then you need a lot error handling for sheets added or deleted.
Try this solution:
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
CodePudding user response：
Create Unique Worksheets
- This will delete each possibly existing sheet before copying the source worksheet and renaming it. Then it will filter it to delete the undesired rows (not entire rows) of the table range in the copied worksheet.
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