Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 233
  • Last Modified:

Copy and paste values into a new spreadsheet

I need to copy and paste values from my current worksheet into multiple new worksheets and then save those files as specific names. The way I need it to work is to copy all the rows that have the same value in column C into separate worksheets. So each file will only have the rows that have the same value in column C. And then save those files with specific names.

For example if I have a value in column C like "LS" I need to take all the rows with that value in it and copy those to a new file and then save that file name as "Daily Quote Report - LS". Then do the same for all the other values in column C. If there is no value in Column C I also need to copy those with the ones that have a value of "BC" into the same file but save that as "Daily Quote Report - BC". There could be on average about 8 different values in column C so there could be 8 files that need to be created.

Any ideas on how this can be done?
0
Lawrence Salvucci
Asked:
Lawrence Salvucci
  • 3
1 Solution
 
John EastonDirectorCommented:
Ironically this is something I was looking at for one of our processes here.  With a bit of help from Google I found some articles I created the below code.  I will be honest and say I am not 100% of what every line does, but it does work for us.

This uses column D to sort and split data.

To use create a new workbook and add a module with the below code.  To run, open this workbook, goto Macro's and run CreateClientWorkbooks.  This will then ask you to select a file (your master data source) and will then create and save the various workbooks.

Option Explicit
' ************************************************
' Variables For File Open Dialogue Box
' ************************************************
Dim strDialogueFileTitle As String
Dim strFilt As String
Dim intFilterIndex As Integer
Dim strCancel As String
Dim strWorkbookNameAndPath As String
' **************************************************
' Workbook And Worksheet Variables
' **************************************************
Dim wkbAllClientsWorkbook As Workbook
Dim wksAllClientsWorksheet As Worksheet
Dim wkbNewClientWorkbook As Workbook
Dim wksNewClientWorksheet As Worksheet

Public Sub CreateClientWorkbooks()
' **************************************************
' Range Variables
' **************************************************
Dim rngRangeToSort As Range
Dim rngRangeOfClientNames As Range
Dim rngClientDataToSave As Range
Dim D As Range

' **************************************************
' Other Variables
' **************************************************
Dim strSingleClientWorkbookPath As String
Dim lngStartingRowForClientWorksheet As Long
Dim lngEndingRowForClientWorksheet As Long
Dim strLastClientName As String
Dim lngNumberOfLinesInAllClients As Long

Application.ScreenUpdating = False

' **************************************************
' Initialize Variables
' **************************************************
strSingleClientWorkbookPath = ThisWorkbook.Path

' ****************************************************************************
' Set Up Filters For Which Files Should Show In The Open File Dialog Box
' ****************************************************************************
strFilt = "Excel Files (*.xls;*.xlsx),*.xls;*.xlsx," & _
          "CSV Files (*.csv),*.csv,"

' ****************************************************************************
' Set Up The Prompt In The Dialogue Box
' ****************************************************************************
intFilterIndex = 1
strDialogueFileTitle = "Select The Daily Report"

' ****************************************************************************
' Present the Open File Dialogue To The User
' ****************************************************************************
Call OpenFileDialogue

' ****************************************************************************
' Notify The User If No File Was Successfully Opened
' ****************************************************************************
If strCancel = "Y" Then
    MsgBox ("An Open Error Occurred Importing Your File Selection")
    Exit Sub
End If

' ********************************************************
' Set The Workbook and Worksheet Variables
' ********************************************************
Set wkbAllClientsWorkbook = ActiveWorkbook
Set wksAllClientsWorksheet = wkbAllClientsWorkbook.ActiveSheet

' ********************************************************
' Locate The Last Data Line In the "All Clients"
' ********************************************************
lngNumberOfLinesInAllClients = wksAllClientsWorksheet.Cells(Rows.Count, "D").End(xlUp).Row

' Clean spaces at start of cells
Dim clean As Range
For Each clean In ActiveSheet.UsedRange
    If Left(clean.Value, 1) = " " Then clean.Value = Right(clean.Value, Len(clean.Value) - 1)
    clean.Value = clean.Value
Next clean

' ********************************************************
' Set The Sort Range - Assume 26 Columns of Data
' ********************************************************
Set rngRangeToSort = Range(wksAllClientsWorksheet.Cells(2, 1), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))

' ********************************************************
' Sort The Worksheet By Client Name In Column A3
' ********************************************************
rngRangeToSort.Sort Key1:=wksAllClientsWorksheet.Range("D2"), Order1:=xlAscending, _
                          Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                          Orientation:=xlTopToBottom, _
                          DataOption1:=xlSortNormal

' *********************************************************
' Now That The Worksheet Is Sorted, Write Out New Workbooks
' For Each Unique Client Name
' *********************************************************
Set rngRangeOfClientNames = Range(wksAllClientsWorksheet.Cells(2, 4), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 4))
strLastClientName = wksAllClientsWorksheet.Cells(2, 4).Value
lngStartingRowForClientWorksheet = 2

For Each D In rngRangeOfClientNames
    If LCase(Trim(D.Value)) <> LCase(Trim(strLastClientName)) Then
        strLastClientName = Trim(D.Offset(-1, 0).Value)
        lngEndingRowForClientWorksheet = D.Offset(-1, 0).Row
        Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                        wksAllClientsWorksheet.Cells(lngEndingRowForClientWorksheet, 26))
        Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)
        lngStartingRowForClientWorksheet = D.Row
        strLastClientName = D.Value
    End If
Next D
' *********************************************************
' Write Out Last Workbook
' *********************************************************
strLastClientName = Trim(wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 4).Value)
Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))
Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)

wkbAllClientsWorkbook.Close SaveChanges:=False

Application.ScreenUpdating = True

End Sub

Private Sub OpenFileDialogue()

' ************************************************
' Display a File Open Dialogue Box For The User
' ************************************************
strCancel = "N"
strWorkbookNameAndPath = Application.GetOpenFilename _
    (FileFilter:=strFilt, _
     FilterIndex:=intFilterIndex, _
     Title:=strDialogueFileTitle)
   
' ************************************************
' Exit If No File Selected
' ************************************************
If strWorkbookNameAndPath = "" Then
    MsgBox ("No Filename Selected")
    strCancel = "Y"
    Exit Sub
ElseIf strWorkbookNameAndPath = "False" Then
    MsgBox ("You Clicked The Cancel Button")
    strCancel = "Y"
    Exit Sub
End If

' ******************************************************
' Now That You Have The User Selected File Name, Open It
' ******************************************************
Workbooks.Open strWorkbookNameAndPath

End Sub

Private Sub AddNewClientWorkbook(PathAndName As String, RangeOfOneClient As Range)
' ******************************************************
' This Creates A Workbook For A Unique Client
' ******************************************************
Set wkbNewClientWorkbook = Workbooks.Add
Set wksNewClientWorksheet = wkbNewClientWorkbook.Sheets(1)

Range(wksAllClientsWorksheet.Cells(1, 1), wksAllClientsWorksheet.Cells(1, 26)).Copy wksNewClientWorksheet.Cells(1, 1)
RangeOfOneClient.Copy wksNewClientWorksheet.Cells(2, 1)

With wkbNewClientWorkbook
    .Title = "Client Sales"
    .Subject = "Sales"
    .SaveAs Filename:=PathAndName
End With

wkbNewClientWorkbook.Close

End Sub

Open in new window

0
 
Lawrence SalvucciSystems ManagerAuthor Commented:
That looks like it will work but there are a couple of things I would like to change. One being the formatting from my original file. I want to copy the formatting, cell widths, etc to these new files. Another is the file names that are being created. I want to be able to change the way the file names are saved. And the location where the files are being saved. I also noticed that when you go to open one of these files it's telling me that the file format is different than specified by the file extension. If I choose yes it will let me open the file but I would like to get rid of that prompt.
0
 
John EastonDirectorCommented:
Some of these questions I'm not sure I have the answers to, but others I can answer.

So...

1. Copy the formatting, cell widths, etc to the new files
This one I don't know the answer to.  On the file we use it for the formating for cells is copied (e.g. font colour, background colour etc), but the cell widths are lost.  I will look in to this further and if I find a solution come back to you seperately.

2. File names and the location where the files are being saved
You should see a line stating:  strSingleClientWorkbookPath = ThisWorkbook.Path
You can change this to:  strSingleClientWorkbookPath = "c:\my_path_here"
I.e. replace my_path_here with where you want them to save.  You could add variable too such as current date etc if you need.

3. File format error
It to had this error, but didn't have time to investigate at the time.  It appear the issue is it is saving the file as xls, but using the xlsx format.  

You should see there is two place with the following:  Call AddNewClientWorkbook

Following this you will see the text ".xls", change to ".xlsx" and this fixes the error.
0
 
John EastonDirectorCommented:
Ok, I think I have been able to resolve the column width issue as well.  I'm sure there is a tidier way to code this, but it works.

In the code I gave you earlier, the last section was a Private Sub called AddNewClientWorkbook

Please replace that sub with the following:

' ******************************************************
' This Creates A Workbook For A Unique Client
' ******************************************************
Set wkbNewClientWorkbook = Workbooks.Add
Set wksNewClientWorksheet = wkbNewClientWorkbook.Sheets(1)

Range(wksAllClientsWorksheet.Cells(1, 1), wksAllClientsWorksheet.Cells(1, 26)).Copy wksNewClientWorksheet.Cells(1, 1)
RangeOfOneClient.Copy wksNewClientWorksheet.Cells(2, 1)
wksNewClientWorksheet.Range("A1").ColumnWidth = wksAllClientsWorksheet.Range("A1").ColumnWidth
wksNewClientWorksheet.Range("B1").ColumnWidth = wksAllClientsWorksheet.Range("B1").ColumnWidth
wksNewClientWorksheet.Range("C1").ColumnWidth = wksAllClientsWorksheet.Range("C1").ColumnWidth
wksNewClientWorksheet.Range("D1").ColumnWidth = wksAllClientsWorksheet.Range("D1").ColumnWidth
wksNewClientWorksheet.Range("E1").ColumnWidth = wksAllClientsWorksheet.Range("E1").ColumnWidth
wksNewClientWorksheet.Range("F1").ColumnWidth = wksAllClientsWorksheet.Range("F1").ColumnWidth
wksNewClientWorksheet.Range("G1").ColumnWidth = wksAllClientsWorksheet.Range("G1").ColumnWidth
wksNewClientWorksheet.Range("H1").ColumnWidth = wksAllClientsWorksheet.Range("H1").ColumnWidth
wksNewClientWorksheet.Range("I1").ColumnWidth = wksAllClientsWorksheet.Range("I1").ColumnWidth
wksNewClientWorksheet.Range("J1").ColumnWidth = wksAllClientsWorksheet.Range("J1").ColumnWidth

With wkbNewClientWorkbook
    .Title = "Client Sales"
    .Subject = "Sales"
    .SaveAs Filename:=PathAndName
End With

wkbNewClientWorkbook.Close

End Sub

Open in new window


You will see the new line which copy the column widths for columns A to J.  If you need more copy and paste those lines and change the two references - i.e. 'J1' become 'K1' etc.

I also see I missed the file name issue.  When updating the path as I described in my earlier post, simply add the file name prefix as follows:

strSingleClientWorkbookPath = "c:\my_path_here\my_report_prefix"
0

Featured Post

Vote for the Most Valuable Expert

It’s time to recognize experts that go above and beyond with helpful solutions and engagement on site. Choose from the top experts in the Hall of Fame or on the right rail of your favorite topic page. Look for the blue “Nominate” button on their profile to vote.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now