Nov 23 2021 11:53 PM
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
Nov 24 2021 03:30 AM
Sub SplitData()
Dim src As Worksheet
Dim trg As Worksheet
Dim lastRow As Long
Dim r As Long
Dim col As New Collection
Dim itm As Variant
Application.ScreenUpdating = False
Set src=Worksheets("Sheet1")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
On Error Resume Next
For r = 2 To lastRow
itm = CStr(src.Range("A" & r).Value)
col.Add Item:=itm, Key:=itm
Next r
On Error GoTo 0
For Each itm In col
Set trg = Nothing
On Error Resume Next
Set trg = Worksheets(itm)
On Error GoTo 0
If trg Is Nothing Then
Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
trg.Name = itm
Else
trg.UsedRange.ClearContents
End If
src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
src.UsedRange.Copy Destination:=trg.Range("A1")
Next itm
src.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Nov 24 2021 03:45 AM
I have been receiving an error type mismatch because i have some strings with that signs | and there are 400+ unique values in Column A
Nov 24 2021 04:13 AM
SolutionYou should always post a relevant example instead of one simplified too far.
| is allowed in a sheet name, but the following characters aren't: \ , / , * , ? , : , [ , ].
To get rid of those:
Sub SplitData()
Dim src As Worksheet
Dim trg As Worksheet
Dim lastRow As Long
Dim r As Long
Dim col As New Collection
Dim itm As Variant
Dim c As Variant
Application.ScreenUpdating = False
Set src=Worksheets("Sheet1")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
On Error Resume Next
For r = 2 To lastRow
itm = CStr(src.Range("A" & r).Value)
col.Add Item:=itm, Key:=itm
Next r
On Error GoTo 0
For Each itm In col
For Each c In Array("\", "/", "*", "?", ":", "[", "]")
itm = Replace(itm, c, "_")
Next c
Set trg = Nothing
On Error Resume Next
Set trg = Worksheets(itm)
On Error GoTo 0
If trg Is Nothing Then
Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
trg.Name = itm
Else
trg.UsedRange.ClearContents
End If
src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
src.UsedRange.Copy Destination:=trg.Range("A1")
Next itm
src.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Nov 24 2021 05:04 AM
Nov 24 2021 05:18 AM
The following will truncate the names to 31 characters. You will have a problem if there are names that differ only beyond the 31st character. For example thisisaridiculouslylongnamenumberone and thisisaridiculouslylongnamenumbertwo. Both will be truncated to thisisaridiculouslylongnamenumb.
Sub SplitData()
Dim src As Worksheet
Dim trg As Worksheet
Dim lastRow As Long
Dim r As Long
Dim col As New Collection
Dim itm As Variant
Dim c As Variant
Application.ScreenUpdating = False
Set src=Worksheets("Sheet1")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
On Error Resume Next
For r = 2 To lastRow
itm = CStr(src.Range("A" & r).Value)
col.Add Item:=itm, Key:=itm
Next r
On Error GoTo 0
For Each itm In col
For Each c In Array("\", "/", "*", "?", ":", "[", "]")
itm = Replace(itm, c, "_")
Next c
itm = Left(itm, 31)
Set trg = Nothing
On Error Resume Next
Set trg = Worksheets(itm)
On Error GoTo 0
If trg Is Nothing Then
Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
trg.Name = itm
Else
trg.UsedRange.ClearContents
End If
src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
src.UsedRange.Copy Destination:=trg.Range("A1")
Next itm
src.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Nov 24 2021 05:22 AM
Nov 24 2021 04:13 AM
SolutionYou should always post a relevant example instead of one simplified too far.
| is allowed in a sheet name, but the following characters aren't: \ , / , * , ? , : , [ , ].
To get rid of those:
Sub SplitData()
Dim src As Worksheet
Dim trg As Worksheet
Dim lastRow As Long
Dim r As Long
Dim col As New Collection
Dim itm As Variant
Dim c As Variant
Application.ScreenUpdating = False
Set src=Worksheets("Sheet1")
src.AutoFilterMode = False
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
On Error Resume Next
For r = 2 To lastRow
itm = CStr(src.Range("A" & r).Value)
col.Add Item:=itm, Key:=itm
Next r
On Error GoTo 0
For Each itm In col
For Each c In Array("\", "/", "*", "?", ":", "[", "]")
itm = Replace(itm, c, "_")
Next c
Set trg = Nothing
On Error Resume Next
Set trg = Worksheets(itm)
On Error GoTo 0
If trg Is Nothing Then
Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
trg.Name = itm
Else
trg.UsedRange.ClearContents
End If
src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
src.UsedRange.Copy Destination:=trg.Range("A1")
Next itm
src.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub