Copying data to new workbook using VBA

[kidwispa]

Hi All,

I received a file every day that I currently run a macro to remove any unnecessary rows, then sort the data alphabetically based on the agent name given in column K. The number of rows for each agent will vary each day, and sometimes agents may not have any data at all...

What I am trying to do is once this particular macro has finished, run another macro that will copy all corresponding rows for each agent into a new workbook for each, naming the file using their name and todays date, and save into a newly created folder named today's date...

So to clarify, all rows that have the name "John Smith" in column K to be copied to a new workbook saved as "John Smith 310511" to be saved in a folder called "31.05.11", and so on until all agents have separate files created all saved in folder "31.05.11"

To make it slightly more complicated, I would also like row 1 to be copied to each sheet as it contains all the headings.

Can anyone help? I hope i've explained myself clearly but if you need any clarification then please let me know...

Thanks in advance

 

[AlphaFrog]

Sub Save_Agent_Data()
    
    Dim wsSource As Worksheet, Lastrow As Long
    Dim Agents As Range, Agent As Range
    Dim wbDest As Workbook
    Dim SavePath As String, AgentFilename As String
    Dim counter As Long
    
    Application.ScreenUpdating = False
    
    Set wsSource = ActiveSheet
    With wsSource
        Lastrow = .Range("K" & Rows.Count).End(xlUp).Row
        .Range("K1:K" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Agents = .Range("K2:K" & Lastrow).SpecialCells(xlCellTypeVisible)
        If .FilterMode Then .ShowAllData
        .Copy
    End With
    Set wbDest = ActiveWorkbook
    wbDest.Sheets(1).UsedRange.ClearContents
    
    SavePath = "C:\" & Format(Date, "dd.mm.yy") & "\"
    If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
    
    For Each Agent In Agents
        wsSource.Range("K:K").AutoFilter Field:=1, Criteria1:=Agent.Value
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            AgentFilename = Agent.Value & Format(Date, " ddmmyy") & ".xlsx"
            On Error Resume Next
                wbDest.SaveAs SavePath & AgentFilename, FileFormat:=51
                    '51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
                    '52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
            On Error GoTo 0
            If wbDest.Name = AgentFilename Then counter = counter + 1
            wbDest.Sheets(1).UsedRange.ClearContents
    Next Agent
    
    wbDest.Close SaveChanges:=False
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox counter & " files saved to " & SavePath, vbInformation, "Save Agent Data"
    
End Sub

 

[kidwispa]

I've been looking around trying to find an answer to the above, and have so far managed to create a new directory folder and file within that directory based on the values in cells M2 & N2:

M2 =CONCATENATE(DAY(A2),MONTH(A2),YEAR(A2)) - this changes the date from 31/05/2011 to 3152011, which I use as the folder name.

N2 =CONCATENATE(K2,M2) - this combines the agent name with cell M2 to give the file name "johnsmith3152011"

Sub Createfiles()
 
    Dim MyFile As String
    Dim sDir As String
    Dim FileName As String
 
 
    MyFile = Sheets("DataSort").Range("M2").Text
 
    FileName = Sheets("DataSort").Range("N2").Text
 
    sDir = "G:\CW\Lates\" & MyFile
 
    MkDir sDir
 
    ChDir sDir
    ActiveWorkbook.SaveAs FileName:=sDir & "\" & FileName
 
End Sub

Now I only want to create one folder per day, but there may be up to 15 different workbooks that will need creating. In column N I have copied the formula shown above down to the last row of data so there will be multiple instances of "johnsmith3152011" so can someone please help me loop this code so it creates a workbook for each unique value in column N?

Thanks

 

[Trevor G]

Here is an idea, Datapig (website) provides an AddIn which you can download, this will split data into separate workbooks. So you could Run the macro to create a folder first and then place the workbooks in that folder from the AddIn

http://www.datapigtechnologies.com/freeware.htm

 

[kidwispa]

Sub Save_Agent_Data()
 
    Dim wsSource As Worksheet, Lastrow As Long
    Dim Agents As Range, Agent As Range
    Dim wbDest As Workbook
    Dim SavePath As String, AgentFilename As String
    Dim counter As Long
 
    Application.ScreenUpdating = False
 
    Set wsSource = ActiveSheet
    With wsSource
        Lastrow = .Range("K" & Rows.Count).End(xlUp).Row
        .Range("K1:K" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Agents = .Range("K2:K" & Lastrow).SpecialCells(xlCellTypeVisible)
        If .FilterMode Then .ShowAllData
        .Copy
    End With
    Set wbDest = ActiveWorkbook
    wbDest.Sheets(1).UsedRange.ClearContents
 
    SavePath = "C:\" & Format(Date, "dd.mm.yy") & "\"
    If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
 
    For Each Agent In Agents
        wsSource.Range("K:K").AutoFilter Field:=1, Criteria1:=Agent.Value
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            AgentFilename = Agent.Value & Format(Date, " ddmmyy") & ".xlsx"
            On Error Resume Next
                wbDest.SaveAs SavePath & AgentFilename, FileFormat:=51
                    '51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
                    '52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
            On Error GoTo 0
            If wbDest.Name = AgentFilename Then counter = counter + 1
            wbDest.Sheets(1).UsedRange.ClearContents
    Next Agent
 
    wbDest.Close SaveChanges:=False
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
 
    MsgBox counter & " files saved to " & SavePath, vbInformation, "Save Agent Data"
 
End Sub

This is perfect - thanks!!!

 

[kidwispa]

AlphaFrog, just one quick question... on the files that are created I want to add the heading "Comments" into cell M1 - can you help?



EDIT - have managed to do it myself now (starting to get the hang of this VBA malarkey!!!)

 

[AlphaFrog]

You're welcome. Glad it works for you.

VBA is really quite easy once you've accumulated the sum of all human knowledge.