Parse Excel sheets into separate files

Introduction

You may have created one too many sheets in Excel, and now you want to move the sheets to separate files. Yes, you can do it by right clicking a sheet and Move/Copy it to a 'new book', but, what if you have more than 255 characters in a cell? It gets truncated. Yes, you can copy/paste and compare cells until you get all of them moved over, but that is tedious.

Using the code

This is an Excel VB macro created with Visual Basic 6.3 for Excel 2003. Onto the code details (skip to the bottom, if you want the full code snippet).

A higher level overview would be:

1. Loop through each worksheet.
   1. Create a new Workbook and copy the old sheet name over to one of the new sheets.
   2. Copy the Range data from the old Workbook.
   3. Collect column width and row height from the old Workbook.
   4. Paste Range data into the new Workbook.
   5. Update column width and row height data in the new Workbook.
   6. Save new Workbook and close it.
2. Repeat for the rest of the sheets.

First, we need to loop through each sheet in the current Workbook.

For Each ws In Worksheets
    ' do some stuff on each worksheet.
Next ws

Next, we are going to need to get the Worksheet's name, for use later on in our For loop.

' get the current worksheet's name.
wsName = ws.Name

Then, I create a new Workbook, which will accept the sheet we want to copy. Yes, this can be done later on in the code as well, but I chose to do it here. We also rename the first sheet with the sheet we currently want to copy over.

'Create a new book, rename the sheet to new name.
Workbooks.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = wsName

Next, we will return to our original Excel file (notice you will have to rename the text from Your Current File to be copied.xls to whatever your file name is. We also select the sheet to be copied and the range of cells. In my example, I am only selecting the A-AA columns and the 1-2000 rows.

' start the copy process to the new workbook.
Application.CutCopyMode = False
Windows("Your Current File to be copied.xls").Activate
Sheets(wsName).Select
Range("A1:AA2000").Select

We then want to store the column width and the row height values in an array for the new sheet, as just copying the range will not carry the formatting over.

' set the array sizes to the range expected
' for rows and columns from previous line.
Dim prevColumnWidth(40)
Dim prevRowHeight(2000)
 
' cycle through the cell range and get each cell w/h data points.
For c = 1 To 40 Step 1
    prevColumnWidth(c - 1) = Columns(c).ColumnWidth
Next c

For c = 1 To 2000 Step 1
    prevRowHeight(c - 1) = Rows(c).RowHeight
Next c

Now, we actually copy over the cells to the new Workbook. Caveat, only the Workbook to be copied is allowed to be open, otherwise this script will not work right.

' now copy the cell range and paste into the new workbook.
Range("A1:AA2000").Select
Selection.Copy
Windows(2).Activate
Range("A1:AA2000").Select
ActiveSheet.Paste

Next, we want to bring over the original column width and the row height to the new Workbook.

' now resize all the cells in the new workbook.
For c = 1 To 40 Step 1
    Columns(c).ColumnWidth = prevColumnWidth(c - 1)
Next c

For c = 1 To 2000 Step 1
    Rows(c).RowHeight = prevRowHeight(c - 1)
Next c

Now that everything is copied over, we want to save the Workbook, then close it.

' default save location is My Documents or the last opened folder. Not sure exactly.
ActiveWorkbook.SaveAs Filename:="Your new File as copied_" & wsName & ".xls", _
          FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close

Here is the complete code script:

Sub CopyRnge2newBook()
'
' CopyRnge2newBook Macro
' Authored by Rich Elswick
'
For Each ws In Worksheets
 
  ' get the current worksheet's name.
  wsName = ws.Name

  'Create a new book, rename the sheet to new name.
  Workbooks.Add
  Sheets("Sheet1").Select
  Sheets("Sheet1").Name = wsName

  ' start the copy process to the new workbook.
  Application.CutCopyMode = False
  Windows("Your Current File to be copied_.xls").Activate
  Sheets(wsName).Select
  Range("A1:AA2000").Select

  ' set the array sizes to the range expected
  ' for rows and columns from previous line.
  Dim prevColumnWidth(40)
  Dim prevRowHeight(2000)

  ' cycle through the cell range and get each cell w/h data points.
  For c = 1 To 40 Step 1
    prevColumnWidth(c - 1) = Columns(c).ColumnWidth
  Next c
  For c = 1 To 2000 Step 1
    prevRowHeight(c - 1) = Rows(c).RowHeight
  Next c

  ' now copy the cell range and paste into the new workbook.
  Range("A1:AA2000").Select
  Selection.Copy
  Windows(2).Activate
  Range("A1:AA2000").Select
  ActiveSheet.Paste

  ' now resize all the cells in the new workbook.
  For c = 1 To 40 Step 1
    Columns(c).ColumnWidth = prevColumnWidth(c - 1)
  Next c
  For c = 1 To 2000 Step 1
    Rows(c).RowHeight = prevRowHeight(c - 1)
  Next c
 
  ' default save location is My Documents
  ' or the last opened folder. Not sure exactly.
  ActiveWorkbook.SaveAs Filename:="Your new File as copied_" & wsName & _
       ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
       ReadOnlyRecommended:=False, CreateBackup:=False
  ActiveWorkbook.Close

  Next ws
End Sub

Points of interest

Note, you should only have the one file you plan to parse opened, otherwise the script may not work properly. Also, this script only copies 37 columns and 2000 rows of data. Should be fine for almost everything you might do. Tagged for future upgrades.

Yes, VB sucks, but if you want to do something in Excel quick and fast, then use it when needed. It is quite powerful in its little block of the programming world, and can be useful at times. Of course, the version of VB editor I used has a lot to be desired, so take it for what it is.

History

• Initial release - September 12, 2008.