Macro: Export each column to a separate sheet

Last week I got a question from Danielle: "I have a spreadsheet with 75 columns each containing between 48 to 50 rows. I would like to be able to export each column to either a separate sheet or a separate file. Sort of like the export worksheets as separate files function.

Does this function already exist? If yes, then which one is it? If not, is this something you could work your magic on to make happen?"

This is not a tool that already exists in ASAP Utilities. I will add one however.

In the mean time you can use the following macro. It will create a new worksheet for each column in your selection and copies the data from that column to the new worksheet. After you have run this macro you can use ASAP Utilities to export each worksheet as a new file.

Sub sbColumnsToSheets()
  ' Purpose: Create a separate worksheet for each column in your selection
  ' the name of the sheet will be the name of the first row in each column.

  ' Usage:
  ' first select the cells then run this macro

  Dim rngSelection                                     As Range
  Dim wsStart                                          As Worksheet
  Dim wsNew                                            As Worksheet
  Dim lRowLast                                         As Long
  Dim lCollast                                         As Long
  Dim lRowFirst                                        As Long
  Dim lColFirst                                        As Long
  Dim lCol                                             As Long
  Dim strSheetName                                     As String

  On Error GoTo sbColumnsToSheets_Error

  ' Quit of no range selected
  If UCase(TypeName(Selection)) <> "RANGE" Then
    MsgBox "Please select the range with the columns you want to " & vbNewLine & _
           "copy into separate sheets.", vbCritical
    Exit Sub
  End If

  If MsgBox("Do you want to copy each one of the " & Selection.Columns.Count & _
            " columns in your selection to a new worksheet?", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub

  Application.ScreenUpdating = False

  Set wsStart = ActiveSheet
  Set rngSelection = Selection
  lRowFirst = rngSelection.Cells(1).Row
  lColFirst = rngSelection.Cells(1).Column
  lRowLast = rngSelection.Cells(rngSelection.Cells.Count).Row
  lCollast = rngSelection.Cells(rngSelection.Cells.Count).Column

  ' loop through the columns
  For lCol = lColFirst To lCollast
    Application.StatusBar = "Processing column " & lCol & " of " & lCollast - lColFirst + 1
    ' add a new sheet at the end
    ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count), Type:=xlWorksheet
    ' make sure the new sheet name is unique
    strSheetName = fnUniqueSheetName(rngSelection.Cells(lRowFirst, lCol).Value)
    ActiveSheet.Name = strSheetName
    Set wsNew = ActiveSheet

    ' copy the column from the original sheet
    wsStart.Activate
    wsStart.Range(Cells(lRowFirst, lCol), Cells(lRowLast, lCol)).Copy

    ' paste the data into the new sheet
    wsNew.Range("A1").PasteSpecial xlPasteValues
    wsNew.Paste

    Application.CutCopyMode = False

  Next lCol

  wsStart.Activate
  Application.ScreenUpdating = True
  Application.StatusBar = False

  On Error GoTo 0
  Exit Sub

sbColumnsToSheets_Error:
  Application.ScreenUpdating = True
  Application.StatusBar = False
  MsgBox "Error " & Err.Number & " (" & Err.Description & ")" & _
         "in procedure sbColumnsToSheets", vbCritical
End Sub

Private Function fnUniqueSheetName(strName As String) As String
  ' Loop through all sheets and see if the name already exists
  ' if is does, add a number to the name and check again.
  ' Repeat until a unique name is found
  ' The maximum length for a sheetname is 31 characters.

  Dim objSheet                                         As Object
  Dim strNewName                                       As String
  Dim i                                                As Long
  ' Certain characters are not allowed in a sheet's namea:
  strName = Replace(strName, ":", "_")
  strName = Replace(strName, "\", "_")
  strName = Replace(strName, "/", "_")
  strName = Replace(strName, "?", "_")
  strName = Replace(strName, "*", "_")
  strName = Replace(strName, "[", "_")
  strName = Replace(strName, "]", "_")
  strNewName = strName
  i = 1
  If Len(strNewName) > 31 Then
    strNewName = Left(strNewName, 21) & ".." & Right(strNewName, 8)
  End If

Start:

  For Each objSheet In ActiveWorkbook.Sheets
    If objSheet.Name = strNewName Then
      strNewName = strName & " (" & i & ")"
      If Len(strNewName) > 31 Then
        strNewName = Left(strNewName, 21) & ".." & Right(strNewName, 8)
      End If
      i = i + 1
      GoTo Start
      Exit For
    End If
  Next

  fnUniqueSheetName = strNewName

End Function

Comments are closed.

Pinterest