Solved

Copy and paste values into a new spreadsheet

Posted on 2014-02-26
4
212 Views
Last Modified: 2014-02-26
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
Comment
Question by:Lawrence Salvucci
  • 3
4 Comments
 
LVL 10

Expert Comment

by:JEaston
ID: 39888406
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
 
LVL 1

Author Comment

by:Lawrence Salvucci
ID: 39888487
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
 
LVL 10

Expert Comment

by:JEaston
ID: 39888530
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
 
LVL 10

Accepted Solution

by:
JEaston earned 500 total points
ID: 39888577
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

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now