Ask a new question

Copy only rows based on unique value in one column and paste them to another worksheet where the worksheet name equals column value

I have multiple worksheets in one shared folder.  There is one master worksheet but I need to break that out into separate worksheets based on each unique value in a column named ModCategory (column V).  So if I were to determine the unique values in this column by using this piece of code:

 

Columns("A:BO").Select
    Columns("A:BO").EntireColumn.AutoFit
    Range("V2").Select
'extract a list of unique ModCategory in this column
ws1.Columns("V:V").Copy _
  Destination:=Range("BQ1")
ws1.Columns("BQ:BQ").AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Range("BP1"), Unique:=True
r = Cells(Rows.Count, "BP").End(xlUp).Row

'set up Criteria Area
Range("BQ1").Value = Range("V2").Value

 

In the end what I would like to do is extract only the rows for each unique value found, copy those rows and columns (A:BO) to another worksheet within that same shared folder where first two characters of that worksheet equal the unique values found in the master worksheet.  This would loop through until all the worksheets in that folder have been found and rows have been copied into each one. 

 

I assume that there are no empty cells in the column "ModCategory" and each unique value could be used as filename.
I also assume that your headings are in the first row.

Copy the code below into a normal module.

Andreas.


Option Explicit

Sub Main()
  Dim R As Range
  Dim Items
  Dim i As Long, c As Long
  Dim WB As Workbook
  'Supress messages from "SaveAs" dialog
  Application.DisplayAlerts = False
  'Screen off, runs faster
  Application.ScreenUpdating = False
  'The current sheet must contain the column
  With ActiveSheet
    'Find the column "ModCategory"
    Set R = .Rows(1).Find("ModCategory", LookIn:=xlValues, LookAt:=xlWhole)
    If R Is Nothing Then
      MsgBox "Column ""ModCategory"" not found."
      Exit Sub
    End If
    'Get the column number
    c = R.Column
    'Build the unique items
    Items = UniqueItems(R.EntireColumn)
    'Be sure the filter is off
    If .FilterMode Then .ShowAllData
    'For each item except the header
    For i = 1 To UBound(Items)
      'Set the autofilter
      .Range("A1").AutoFilter c, Items(i)
      'Get the visible cells
      Set R = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
      'Create a new file with only one sheet
      Set WB = Workbooks.Add(xlWBATWorksheet)
      'Copy the cells
      R.Copy Cells(1, 1)
      'Save and close it
      WB.Close True, ThisWorkbook.Path & "\" & Items(i)
    Next
  End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Private Function UniqueItems(ByVal R As Range, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant
  'Return an array with all unique values in R
  Dim Area As Range, Data
  Dim i As Long, j As Long
  Dim Dict As Object 'Scripting.Dictionary
  Set R = Intersect(R.Parent.UsedRange, R)
  If R Is Nothing Then
    UniqueItems = Array()
    Exit Function
  End If
  Set Dict = CreateObject("Scripting.Dictionary")
  Dict.CompareMode = Compare
  For Each Area In R.Areas
    Data = Area
    If IsArray(Data) Then
      For i = 1 To UBound(Data)
        For j = 1 To UBound(Data, 2)
          If Not Dict.Exists(Data(i, j)) Then Dict.Add Data(i, j), 0
        Next
      Next
    Else
      If Not Dict.Exists(Data) Then Dict.Add Data, 0
    End If
  Next
  UniqueItems = Dict.Keys
End Function

Was this reply helpful?

Sorry this didn't help.

Great! Thanks for your feedback.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this reply?

Thanks for your feedback.

 
 

Question Info

Last updated October 5, 2021 Views 687 Applies to: