Help to adapt this VBA code

[thedeadzeds]

Hi All,

I was wondering if there was a way to adapt this? At the moment it saves the individual workbooks to a single folder. Is there a way to save each one to an individual folder based on the same name as the filter. Also, is there a way to save this as an Excel workbook rather than CSV and copy the formatting, ie, font, colours etc.

Many thanks

Sub thedeadzeds()

Dim Cl As Range

Dim Ws As Worksheet, Ws2 As Worksheet

Dim Ky As Variant



Application.ScreenUpdating = False

Set Ws = Sheets("[COLOR=#ff0000]pcode[/COLOR]")

If Ws.AutoFilterMode Then Ws.AutoFilterMode = False

With CreateObject("scripting.dictionary")

For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))

.Item(Cl.Value) = Empty

Next Cl

For Each Ky In .Keys

Ws.Copy

Set Ws2 = ActiveSheet

Ws2.Range("A1").AutoFilter 4, "<>" & Ky

Ws2.AutoFilter.Range.Offset(1).EntireRow.Delete

Ws2.AutoFilterMode = False

Ws2.Parent.SaveAs "[COLOR=#ff0000]C:\Users\OneDrive\test\[/COLOR]" & Ky & ".csv", 6

Ws2.Parent.Close False

Next Ky

End With

End Sub

 

[thedeadzeds]

Sorry to bump this but really hoping to get some help asap as my deadline is tomorrow

 

[HaHoBe]

Hi thedeadzeds(,

maybe

Sub MrE1171168()
'https://www.mrexcel.com/board/threads/help-to-adapt-this-vba-code.1171168/

Dim Cl As Range
Dim Ws As Worksheet
Dim Ky As Variant

Const cstrPath As String = "C:\Users\OneDrive\test\"

Application.ScreenUpdating = False

Set Ws = Sheets("pcode")
If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
With CreateObject("scripting.dictionary")
  For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
  Next Cl
  For Each Ky In .Keys
    Ws.Copy
    With ActiveSheet
      .Range("A1").AutoFilter 4, "<>" & Ky
      .AutoFilter.Range.Offset(1).EntireRow.Delete
      .AutoFilterMode = False
      On Error Resume Next
      MkDir cstrPath & Ky
      On Error GoTo 0
      .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51
      .Parent.Close False
    End With
  Next Ky
End With

Set Ws = Nothing

End Sub

Ciao,
Holger

 

[thedeadzeds]

Hi thedeadzeds(,

maybe

Sub MrE1171168()
'https://www.mrexcel.com/board/threads/help-to-adapt-this-vba-code.1171168/

Dim Cl As Range
Dim Ws As Worksheet
Dim Ky As Variant

Const cstrPath As String = "C:\Users\OneDrive\test\"

Application.ScreenUpdating = False

Set Ws = Sheets("pcode")
If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
With CreateObject("scripting.dictionary")
  For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
  Next Cl
  For Each Ky In .Keys
    Ws.Copy
    With ActiveSheet
      .Range("A1").AutoFilter 4, "<>" & Ky
      .AutoFilter.Range.Offset(1).EntireRow.Delete
      .AutoFilterMode = False
      On Error Resume Next
      MkDir cstrPath & Ky
      On Error GoTo 0
      .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51
      .Parent.Close False
    End With
  Next Ky
End With

Set Ws = Nothing

End Sub

Ciao,
Holger

Thank you for this. I seem to be getting the following error message:

Runtime error 1004 - Saveas method of workbook classs failed

 

[HaHoBe]

Hi thedeadzeds,

my bad - I missed the line Ws.Copy from the original code.

Sub MrE1171168_02()
'https://www.mrexcel.com/board/threads/help-to-adapt-this-vba-code.1171168/

Dim Cl As Range
Dim Ws As Worksheet
Dim Ky As Variant

Const cstrPath As String = "C:\Users\OneDrive\test\"

Application.ScreenUpdating = False

Set Ws = Sheets("pcode")
If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
With CreateObject("scripting.dictionary")
  For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
  Next Cl
  For Each Ky In .Keys
    On Error Resume Next
    MkDir cstrPath & Ky
    If Err = 0 Then
      On Error GoTo 0
      Ws.Copy
      With ActiveSheet
        .Range("A1").AutoFilter 4, "<>" & Ky
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .AutoFilterMode = False
        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51
        .Parent.Close False
      End With
    Else
      Debug.Print "Problems with " & Ky
    End If
    Err.Clear
  Next Ky
End With

Set Ws = Nothing

End Sub

Ciao,
Holger

 

[thedeadzeds]

Hi thedeadzeds,

my bad - I missed the line Ws.Copy from the original code.

Sub MrE1171168_02()
'https://www.mrexcel.com/board/threads/help-to-adapt-this-vba-code.1171168/

Dim Cl As Range
Dim Ws As Worksheet
Dim Ky As Variant

Const cstrPath As String = "C:\Users\OneDrive\test\"

Application.ScreenUpdating = False

Set Ws = Sheets("pcode")
If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
With CreateObject("scripting.dictionary")
  For Each Cl In Ws.Range("D2", Ws.Range("D" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
  Next Cl
  For Each Ky In .Keys
    On Error Resume Next
    MkDir cstrPath & Ky
    If Err = 0 Then
      On Error GoTo 0
      Ws.Copy
      With ActiveSheet
        .Range("A1").AutoFilter 4, "<>" & Ky
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .AutoFilterMode = False
        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51
        .Parent.Close False
      End With
    Else
      Debug.Print "Problems with " & Ky
    End If
    Err.Clear
  Next Ky
End With

Set Ws = Nothing

End Sub

Ciao,
Holger

Thanks so much, is there a way to save as values and keep the formating , as currently it is saving as links to the original sheet

 

[HaHoBe]

Hi thedeadzeds,

please do not use full quotes as that post is located directly above.

Try adding

        .AutoFilterMode = False
        .UsedRange.Value = .UsedRange.Value   'this line should convert the formulas into values
        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51

Sorry I don´t understand the question about the formatting, it should remain the same as on the original sheet.

Viao,
Holger

 

[thedeadzeds]

Hi thedeadzeds,

please do not use full quotes as that post is located directly above.

Try adding

        .AutoFilterMode = False
        .UsedRange.Value = .UsedRange.Value   'this line should convert the formulas into values
        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51

Sorry I don´t understand the question about the formatting, it should remain the same as on the original sheet.

Viao,
Holger

Thanks for this. I'm still getting the same Save as error message: My code is as per below:

Sub MrE1171168_02()
'https://www.mrexcel.com/board/threads/help-to-adapt-this-vba-code.1171168/

Dim Cl As Range
Dim Ws As Worksheet
Dim Ky As Variant

Const cstrPath As String = "C:\Users\Test"

Application.ScreenUpdating = False

Set Ws = Sheets("Calc Current Month")
If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
With CreateObject("scripting.dictionary")
  For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
  Next Cl
  For Each Ky In .Keys
    On Error Resume Next
    MkDir cstrPath & Ky
    If Err = 0 Then
      On Error GoTo 0
      Ws.Copy
      With ActiveSheet
        .Range("A1").AutoFilter 1, "<>" & Ky
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .AutoFilterMode = False
        .UsedRange.Value = .UsedRange.Value   'this line should convert the formulas into values
        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51
        .Parent.Close False
      End With
    Else
      Debug.Print "Problems with " & Ky
    End If
    Err.Clear
  Next Ky
End With

Set Ws = Nothing

End Sub

 

[HaHoBe]

Hi thedeadzeds,,

in the last code you posted there is a missing backslash in

Const cstrPath As String = "C:\Users\Test"

With this line you will add the Key to the basic name of the folder.

I ran the code on a sample but no errors were reported. According to this link the code line should be changed from

        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 51

to

        .Parent.SaveAs cstrPath & Ky & "\" & Ky & ".xlsx", 1

Ciao,
Holger