locked
Save multiple workbooks into unique filepaths in the network drive RRS feed

  • Question

  • Hi excel guru's, 

    I have a VBA coding that currently splits up to 133 files into my personal drive. However I need all 133 files to be distributed to unique filespaths on the network. Each of these have their own filepath. Where abouts to I amend my current VBA coding to have these automatically saved in those filepaths?

    My current VBA coding:


    Sub Copy_To_Workbooks()

        Dim My_Range As Range
        Dim FieldNum As Long
        Dim FileExtStr As String
        Dim FileFormatNum As Long
        Dim CalcMode As Long
        Dim ViewMode As Long
        Dim ws2 As Worksheet
        Dim MyPath As String
        Dim foldername As String
        Dim Lrow As Long
        Dim cell As Range
        Dim CCount As Long
        Dim WSNEW As Worksheet
        Dim ErrNum As Long
        Dim FixedRange As Range
        Set FixedRange = Range("A1:G4")

        Set My_Range = Range("A5:G" & LastRow(ActiveSheet))
        My_Range.Parent.Select

        If ActiveWorkbook.ProtectStructure = True Or _
           My_Range.Parent.ProtectContents = True Then
            MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                   vbOKOnly, "Copy to new workbook"
            Exit Sub
        End If

     
        FieldNum = 1


        My_Range.Parent.AutoFilterMode = False


        If Val(Application.Version) < 12 Then

            FileExtStr = ".xls": FileFormatNum = -4143
        Else
      
            If ActiveWorkbook.FileFormat = 56 Then
                FileExtStr = ".xls": FileFormatNum = 56
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        End If


        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView
        ActiveSheet.DisplayPageBreaks = False


        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets("SPEC.DONATIONS").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0


        Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
        ws2.Name = "SPEC.DONATIONS"


        MyPath = Application.DefaultFilePath


        If Right(MyPath, 1) <> "\" Then
            MyPath = MyPath & "\"
        End If


        foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
        MkDir foldername

        With ws2

            My_Range.Columns(FieldNum).AdvancedFilter _
                    Action:=xlFilterCopy, _
                    CopyToRange:=.Range("A3"), Unique:=True


            Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
            For Each cell In .Range("A4:A" & Lrow)


                My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

      
                CCount = 0
                On Error Resume Next
                CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                         .Areas(1).Cells.Count
                On Error GoTo 0
                If CCount = 0 Then
                    MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                         & vbNewLine & "It is not possible to copy the visible data." _
                         & vbNewLine & "Tip: Sort your data before you use this macro.", _
                           vbOKOnly, "Split in worksheets"
                Else
                
              
                    Set WSNEW = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
       
                    FixedRange.Copy
                    With WSNEW.Range("A1")
                        .PasteSpecial Paste:=xlPasteValues
                        .PasteSpecial Paste:=xlPasteFormats
                    End With
                    My_Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNEW.Range("A5")
                        .PasteSpecial Paste:=8
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With

                    With WSNEW.PageSetup
                        .Orientation = xlPortrait
                        .PaperSize = xlPaperA4
                        .Zoom = 83
                    End With
                                                   
                    On Error Resume Next
                    WSNEW.Parent.SaveAs foldername & _
                                        cell.Value & " Specified Donations" & FileExtStr, FileFormatNum
                    If Err.Number > 0 Then
                        Err.Clear
                        ErrNum = ErrNum + 1

                        WSNEW.Parent.SaveAs foldername & _
                                            "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum

                        .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
                                                        "Error_" & Format(ErrNum, "0000") & FileExtStr & """)"

                        .Cells(cell.Row, "A").Interior.Color = vbRed
                    Else
                        .Cells(cell.Row, "B").Formula = _
                        "=Hyperlink(""" & foldername & cell.Value & " Specified Donations" & FileExtStr & """)"
                    End If

                    WSNEW.Parent.Close False
                    On Error GoTo 0
                End If

      
                My_Range.AutoFilter Field:=FieldNum

            Next cell
            .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
            .Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
            .Cells(3, "A").Value = "Unique Values"
            .Cells(3, "B").Value = "Full Path and File name"
            .Cells(3, "A").Font.Bold = True
            .Cells(3, "B").Font.Bold = True
            .Columns("A:B").AutoFit

        End With


        My_Range.Parent.Select
        ActiveWindow.View = ViewMode
        ws2.Select
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .Calculation = CalcMode
        End With

    End Sub





    Tuesday, September 13, 2016 5:02 AM

Answers

  • Hi,

    To save these workbooks into the network drive, using the full path of the network drive as your foldername


    For example, I am using the following to save into OneDrive

         foldername = "https://d.docs.live.net/(myOneDriveCID)" & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"

         MkDir foldername

    Or example:

         foldername = "\\server\share" & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"

         MkDir foldername

    Besides, you could visit How to programmatically save a file to a network drive in Excel


    • Proposed as answer by Chenchen Li Sunday, September 18, 2016 11:16 PM
    • Marked as answer by Chenchen Li Tuesday, September 20, 2016 7:39 AM
    • Edited by Chenchen Li Friday, October 7, 2016 11:52 AM clarify
    Wednesday, September 14, 2016 2:54 AM