Copy data from a worksheet based on a change in criteria and then save the new workbook

[jdhfch]

Hi there,

please can someone help?

Using the example below.

I am wanting to use code to copy all data using an individual Account Manager name (in this instance John Jones) into a new workbook, including copying the same formatting, then call the new workbook John Jones and whatever name I input into cell B1 to a destination I choose each time I run the code. In this case, the workbook would be called Cafe Workbook - John Jones.xlsx. Then to work through to do the same for Fred Flinstone etc - there will be between 20 and 30 names to do this for. The data can either be sorted first, or unsorted, whichever works best.

Many thanks

 

[HighAndWilder]

Hi there,

please can someone help?

Using the example below.

I am wanting to use code to copy all data using an individual Account Manager name (in this instance John Jones) into a new workbook, including copying the same formatting, then call the new workbook John Jones and whatever name I input into cell B1 to a destination I choose each time I run the code. In this case, the workbook would be called Cafe Workbook - John Jones.xlsx. Then to work through to do the same for Fred Flinstone etc - there will be between 20 and 30 names to do this for. The data can either be sorted first, or unsorted, whichever works best.

View attachment 122013

Many thanks

Try this on a COPY of your data.

You will need to state the name of the source and destination worksheets at the top of the code where indicated.

Previous workbook with the same name will be deleted before the new workbook is created..

No sorting yet. What do you want to sort on and just in the destination sheet?

Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String

  ' **** Change reference to the sheet containing the data. ****
  Set Ws = Worksheets("AccountManagers")
  
  ' **** Set the destination sheet name. ****
  strDestinationSheet = "Data"
  
  ActiveWorkbook.Save
  
  Application.ScreenUpdating = False
  
  Set Wb = ThisWorkbook
  
  strPath = fncSelectFolder
    
  If strPath = "" Then
    Exit Sub
  End If
  
  Ws.Activate
    
  last = Ws.Cells(Rows.Count, "C").End(xlUp).Row
  
  arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")
    
  Set rng = Ws.Range("A2:E" & last)
  
  Application.DisplayAlerts = False
  
  For i = LBound(arr) To UBound(arr)
  
    With rng
      
      .AutoFilter Field:=3, Criteria1:=arr(i, 1)
      
      .SpecialCells(xlCellTypeVisible).Copy
      
      Sheets.Add After:=Sheets(Sheets.Count)
      
      ActiveSheet.Range("A1").PasteSpecial xlPasteAll
      
      ActiveSheet.Copy
      
      With ActiveSheet
        .Name = strDestinationSheet
        .Cells.EntireColumn.AutoFit
        .Cells(1, 1).Select
      End With
      
      On Error Resume Next
      Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
      On Error GoTo 0
      
      With ActiveWorkbook
        .SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
        .Close
      End With
      
      Ws.Activate
      
      Wb.Sheets(Sheets.Count).Delete
      
      .AutoFilter
    
    End With

  Next i
  
  Application.DisplayAlerts = True
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
  
  MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"

End Sub

Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String

  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Destination Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
      Exit Function
    End If
    myFolder = .SelectedItems(1) & "\"
  End With
  
  fncSelectFolder = myFolder
  
End Function

 

[jdhfch]

Try this on a COPY of your data.

You will need to state the name of the source and destination worksheets at the top of the code where indicated.

Previous workbook with the same name will be deleted before the new workbook is created..

No sorting yet. What do you want to sort on and just in the destination sheet?

Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String

  ' **** Change reference to the sheet containing the data. ****
  Set Ws = Worksheets("AccountManagers")
 
  ' **** Set the destination sheet name. ****
  strDestinationSheet = "Data"
 
  ActiveWorkbook.Save
 
  Application.ScreenUpdating = False
 
  Set Wb = ThisWorkbook
 
  strPath = fncSelectFolder
   
  If strPath = "" Then
    Exit Sub
  End If
 
  Ws.Activate
   
  last = Ws.Cells(Rows.Count, "C").End(xlUp).Row
 
  arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")
   
  Set rng = Ws.Range("A2:E" & last)
 
  Application.DisplayAlerts = False
 
  For i = LBound(arr) To UBound(arr)
 
    With rng
     
      .AutoFilter Field:=3, Criteria1:=arr(i, 1)
     
      .SpecialCells(xlCellTypeVisible).Copy
     
      Sheets.Add After:=Sheets(Sheets.Count)
     
      ActiveSheet.Range("A1").PasteSpecial xlPasteAll
     
      ActiveSheet.Copy
     
      With ActiveSheet
        .Name = strDestinationSheet
        .Cells.EntireColumn.AutoFit
        .Cells(1, 1).Select
      End With
     
      On Error Resume Next
      Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
      On Error GoTo 0
     
      With ActiveWorkbook
        .SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
        .Close
      End With
     
      Ws.Activate
     
      Wb.Sheets(Sheets.Count).Delete
     
      .AutoFilter
   
    End With

  Next i
 
  Application.DisplayAlerts = True
 
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
 
  MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"

End Sub

Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String

  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Destination Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
      Exit Function
    End If
    myFolder = .SelectedItems(1) & "\"
  End With
 
  fncSelectFolder = myFolder
 
End Function

Thank you. I have amended to this, but I get an runtime error 1004

Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String

' **** Change reference to the sheet containing the data. ****
Set Ws = Worksheets("TTT")

' **** Set the destination sheet name. ****
strDestinationSheet = "DATA"

ActiveWorkbook.Save

Application.ScreenUpdating = False

Set Wb = ThisWorkbook

strPath = fncSelectFolder

If strPath = "" Then
Exit Sub
End If

Ws.Activate

last = Ws.Cells(Rows.Count, "C").End(xlUp).Row

arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")

Set rng = Ws.Range("A3:N" & last)

Application.DisplayAlerts = False

For i = LBound(arr) To UBound(arr)

With rng

.AutoFilter Field:=3, Criteria1:=arr(i, 1)

.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Range("A1").PasteSpecial xlPasteAll

ActiveSheet.Copy

With ActiveSheet
.Name = strDestinationSheet
.Cells.EntireColumn.AutoFit
.Cells(1, 1).Select
End With

On Error Resume Next
Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
On Error GoTo 0

With ActiveWorkbook
.SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
.Close
End With

Ws.Activate

Wb.Sheets(Sheets.Count).Delete

.AutoFilter

End With

Next i

Application.DisplayAlerts = True

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"

End Sub

Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = "Select A Destination Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Function
End If
myFolder = .SelectedItems(1) & "\"
End With

fncSelectFolder = myFolder

End Function

 

[HighAndWilder]

Thank you. I have amended to this, but I get an runtime error 1004

Private Sub subFilterData()
Dim rng As Range
Dim last As Long
Dim sht As String
Dim arr() As Variant
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim strPath As String
Dim strDestinationSheet As String

' **** Change reference to the sheet containing the data. ****
Set Ws = Worksheets("TTT")

' **** Set the destination sheet name. ****
strDestinationSheet = "DATA"

ActiveWorkbook.Save

Application.ScreenUpdating = False

Set Wb = ThisWorkbook

strPath = fncSelectFolder

If strPath = "" Then
Exit Sub
End If

Ws.Activate

last = Ws.Cells(Rows.Count, "C").End(xlUp).Row

arr = Evaluate("UNIQUE(" & Ws.Range("C3:C" & last).Address & ")")

Set rng = Ws.Range("A3:N" & last)

Application.DisplayAlerts = False

For i = LBound(arr) To UBound(arr)

With rng

.AutoFilter Field:=3, Criteria1:=arr(i, 1)

.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Range("A1").PasteSpecial xlPasteAll

ActiveSheet.Copy

With ActiveSheet
.Name = strDestinationSheet
.Cells.EntireColumn.AutoFit
.Cells(1, 1).Select
End With

On Error Resume Next
Kill (strPath & arr(i, 1) & " - " & Ws.Range("B1")) & ".xlsx"
On Error GoTo 0

With ActiveWorkbook
.SaveAs Filename:=strPath & arr(i, 1) & " - " & Ws.Range("B1")
.Close
End With

Ws.Activate

Wb.Sheets(Sheets.Count).Delete

.AutoFilter

End With

Next i

Application.DisplayAlerts = True

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

MsgBox UBound(arr) & " new workbooks created.", vbOKOnly, "Confirmation"

End Sub

Private Function fncSelectFolder() As String
Dim FldrPicker As FileDialog
Dim myFolder As String

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = "Select A Destination Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Function
End If
myFolder = .SelectedItems(1) & "\"
End With

fncSelectFolder = myFolder

End Function

On which line do you get the error?

 

[jdhfch]

On which line do you get the error?

I managed to figure it out - thank you for your help

 

[smozgur]

On which line do you get the error?

I managed to figure it out - thank you for your help

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. If you made adjustments on the provided code to make it work in your case, then it would be also good idea to let others know about that.
No further action is required for this thread.