Aug 28 2021 12:42 AM
Hi,
I have a file which has filler lines on top and bottom of a a defined datarange/dataset.
What I would like to do is run a macro or script to filter through each value in Column A (Leader, see attached file) of the named range, and then save each result in a new file (named Review-LeaderValue.xlsx for example, where the "LeaderValue" is the resulting value in the filter of column A).
Also, I'd like put the now unique value in the Leader Column into cell B1.
I've attached an example file of how it looks - and it has two sheets. "Dataset" to show how the original would look and "Example Outcome" to show what I want to try to achieve.
If it was just a pure dataset it would be easier to accomodate, but as I need to retain the lines above and below the set I am a tad lost.
Øystein
Aug 28 2021 08:08 AM
SolutionHere you go:
Sub SplitToFiles()
Const h = 6 ' Header row
Dim ws As Worksheet ' Source sheet
Dim r As Long ' Row on source sheet
Dim m As Long ' Last data row
Dim wb As Workbook ' New workbook
Dim wt As Worksheet ' New worksheet
Dim col As New Collection ' Unique leaders
Dim v As Variant ' Leader
Dim p As String ' Path
Application.ScreenUpdating = False
p = ThisWorkbook.Path & Application.PathSeparator
Set ws = ActiveSheet
m = ws.Range("A" & h).End(xlDown).Row
On Error Resume Next
For r = h + 1 To m
col.Add Item:=ws.Range("A" & r).Value, Key:=ws.Range("A" & r).Value
Next r
On Error GoTo 0
For Each v In col
ws.Copy
Set wb = ActiveWorkbook
Set wt = wb.Worksheets(1)
wt.Range("B1").Value = v
wt.Range("A" & h).CurrentRegion.AutoFilter Field:=1, Criteria1:="<>" & v
wt.Range("A" & h + 1 & ":A" & m).EntireRow.Delete
wt.Range("A" & h).CurrentRegion.AutoFilter
wb.SaveAs Filename:=p & v & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
Next v
Application.ScreenUpdating = True
End Sub
Aug 28 2021 08:08 AM
SolutionHere you go:
Sub SplitToFiles()
Const h = 6 ' Header row
Dim ws As Worksheet ' Source sheet
Dim r As Long ' Row on source sheet
Dim m As Long ' Last data row
Dim wb As Workbook ' New workbook
Dim wt As Worksheet ' New worksheet
Dim col As New Collection ' Unique leaders
Dim v As Variant ' Leader
Dim p As String ' Path
Application.ScreenUpdating = False
p = ThisWorkbook.Path & Application.PathSeparator
Set ws = ActiveSheet
m = ws.Range("A" & h).End(xlDown).Row
On Error Resume Next
For r = h + 1 To m
col.Add Item:=ws.Range("A" & r).Value, Key:=ws.Range("A" & r).Value
Next r
On Error GoTo 0
For Each v In col
ws.Copy
Set wb = ActiveWorkbook
Set wt = wb.Worksheets(1)
wt.Range("B1").Value = v
wt.Range("A" & h).CurrentRegion.AutoFilter Field:=1, Criteria1:="<>" & v
wt.Range("A" & h + 1 & ":A" & m).EntireRow.Delete
wt.Range("A" & h).CurrentRegion.AutoFilter
wb.SaveAs Filename:=p & v & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
Next v
Application.ScreenUpdating = True
End Sub