Macro to save and separate multiple worksheets as individual files in .csv format

[Ay Sticky]

Please I have multiple worksheets in a workbook saved in xlsx. The task I need the vba for, is to separate these worksheets into individual workbooks in csv format with their names corresponding to the names as used in the worksheets. It would also be great if all separated sheets could all be saved in same directory.

 

[Marc L]

Ok I'm ready now, come back in less than 15 minutes for posting a first try …​

 

[Marc L]

According to your last attachment the 'process all at once' VBA demonstration to paste to the top of a module​

(for Excel Windows versions older than 2007 version just remove the statement PtrSafe …) :​

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath$) As Boolean

Sub Demo2()
  Const D = "C:\Users\PC\Desktop\study mst\coordinate extractions\coordinate CSVs\", E = ".csv"
    Dim F$, N%, P$, S$(), U&, Z$, L&, R&
        F = Dir$(D & "*" & E):  If F = "" Then Beep: Exit Sub
        N = FreeFile
    Do
        P = D & Replace(F, E, "\")
    If MakeSureDirectoryPathExists(P) Then
            Application.StatusBar = "       Processing " & F
            Open D & F For Input As #N
            S = Split(Input(LOF(N), #N), vbLf)
            Close #N
            U = UBound(S) + (S(UBound(S)) = "")
            Z = " (" & String$(Len(CStr(U)), "0") & ") "
        For L = 0 To U - 1
            Open P & Replace(F, E, Format(L + 1, Z) & E) For Output As #N
            Print #N, "Latitude,Longitude"; vbLf; S(L);
            For R = L + 1 To U:   Print #N, vbLf; S(R); vbLf; S(L);:   Next
            Close #N
        Next
    End If
               F = Dir$
    Loop Until F = ""
        Application.Speech.Speak "Done", True
        Application.StatusBar = False
End Sub

 

[Marc L]

As I was on phone and late I wrote an error so I must correct my sentence :​

​

For Excel Windows versions prior to 2007 version just remove PtrSafe statement …​

​

If a moderator can update my previous post and delete this one, thanks !​

 

[Ay Sticky]

According to your last attachment the 'process all at once' VBA demonstration to paste to the top of a module​

(for Excel Windows versions older than 2007 version just remove the statement PtrSafe …) :​

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath$) As Boolean

Sub Demo2()
  Const D = "C:\Users\PC\Desktop\study mst\coordinate extractions\coordinate CSVs\", E = ".csv"
    Dim F$, N%, P$, S$(), U&, Z$, L&, R&
        F = Dir$(D & "*" & E):  If F = "" Then Beep: Exit Sub
        N = FreeFile
    Do
        P = D & Replace(F, E, "\")
    If MakeSureDirectoryPathExists(P) Then
            Application.StatusBar = "       Processing " & F
            Open D & F For Input As #N
            S = Split(Input(LOF(N), #N), vbLf)
            Close #N
            U = UBound(S) + (S(UBound(S)) = "")
            Z = " (" & String$(Len(CStr(U)), "0") & ") "
        For L = 0 To U - 1
            Open P & Replace(F, E, Format(L + 1, Z) & E) For Output As #N
            Print #N, "Latitude,Longitude"; vbLf; S(L);
            For R = L + 1 To U:   Print #N, vbLf; S(R); vbLf; S(L);:   Next
            Close #N
        Next
    End If
               F = Dir$
    Loop Until F = ""
        Application.Speech.Speak "Done", True
        Application.StatusBar = False
End Sub

Whoa!! You did it! This is so magnificent! Imagine all these tasks in one code. Kudos.

But there's one issue with Task #3b. The copying of the first row into the blanks exceeded the last row. It added additional one row. The blank row filling is to stop at the blank row before the last row with data.

 

[Marc L]

Another try (just check the 2/3 first files result and the last 2/3) :​

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath$) As Boolean

Sub Demo2a()
  Const D = "C:\Users\PC\Desktop\study mst\coordinate extractions\coordinate CSVs\", E = ".csv"
    Dim F$, N%, P$, S$(), U&, Z$, L&, R&
        F = Dir$(D & "*" & E):  If F = "" Then Beep: Exit Sub
        N = FreeFile
    Do
        P = D & Replace(F, E, "\")
    If MakeSureDirectoryPathExists(P) Then
            Application.StatusBar = "       Processing " & F
            Open D & F For Input As #N
            S = Split(Input(LOF(N), #N), vbLf)
            Close #N
            U = UBound(S) + (S(UBound(S)) = "")
            Z = " (" & String$(Len(CStr(U)), "0") & ") "
        For L = 0 To U - 1
            Open P & Replace(F, E, Format(L + 1, Z) & E) For Output As #N
            Print #N, "Latitude,Longitude"; vbLf; S(L);
            For R = L + 1 To U - 1:  Print #N, vbLf; S(R); vbLf; S(L);:  Next
            Print #N, vbLf; S(U);
            Close #N
        Next
    End If
               F = Dir$
    Loop Until F = ""
        Application.Speech.Speak "Done", True
        Application.StatusBar = False
End Sub

 

[Ay Sticky]

Another try (just check the 2/3 first files result and the last 2/3) :​

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath$) As Boolean

Sub Demo2a()
  Const D = "C:\Users\PC\Desktop\study mst\coordinate extractions\coordinate CSVs\", E = ".csv"
    Dim F$, N%, P$, S$(), U&, Z$, L&, R&
        F = Dir$(D & "*" & E):  If F = "" Then Beep: Exit Sub
        N = FreeFile
    Do
        P = D & Replace(F, E, "\")
    If MakeSureDirectoryPathExists(P) Then
            Application.StatusBar = "       Processing " & F
            Open D & F For Input As #N
            S = Split(Input(LOF(N), #N), vbLf)
            Close #N
            U = UBound(S) + (S(UBound(S)) = "")
            Z = " (" & String$(Len(CStr(U)), "0") & ") "
        For L = 0 To U - 1
            Open P & Replace(F, E, Format(L + 1, Z) & E) For Output As #N
            Print #N, "Latitude,Longitude"; vbLf; S(L);
            For R = L + 1 To U - 1:  Print #N, vbLf; S(R); vbLf; S(L);:  Next
            Print #N, vbLf; S(U);
            Close #N
        Next
    End If
               F = Dir$
    Loop Until F = ""
        Application.Speech.Speak "Done", True
        Application.StatusBar = False
End Sub

Perfect! Perfect!! Perfect!!!
Job succinctly done 100% by you. I never believed vba could do all these at a go, until now. Thank you for your patience, professionalism and encouragement. Many thanks also to those keeping this wonderful web platform running. We hope to land here again if we find any difficulty with excel.

Now should I mark this quoted post as the answer to the thread or I should just leave the original post I already marked?

 

[Marc L]

According to the initial post just leave the original post already marked; after it this is just a bonus, like a cherry on the cake !​

 

[Ay Sticky]

​

According to the initial post just leave the original post already marked; after it this is just a bonus, like a cherry on the cake !​

Alright. Thank you once again. You've saved me a hell of stress.