Split Data in Multiple Workbooks according to cell value

[Maria Clara]

Hi Guys, I'm using the code below to split data into multiple sheets but instead of splitting it in the same sheet I'd like it to be split in a new workbook. I mean, open a new workbook for each cell value informed.

Could anyone help me on this?

thank you!!!!

 Sub Splitdatatosheets()

Application.ScreenUpdating = False

Dim rng As Range
Dim rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Set rng = Sheets("FINAL AWARD").Range("K2")
Set rng1 = Sheets("FINAL AWARD").Range("A2:K2")
vrb = False
Do While rng <> ""
  For Each sht In Worksheets
  If sht.Name = Left(rng.Value, 31) Then
  sht.Select
  Range("A1").Select
  Do While Selection <> ""
  ActiveCell.Offset(1, 0).Activate
  Loop
  rng1.Copy ActiveCell
  ActiveCell.Offset(1, 0).Activate
  Set rng1 = rng1.Offset(1, 0)
  Set rng = rng.Offset(1, 0)
  vrb = True
  End If
  Next sht
  If vrb = False Then
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Left(rng.Value, 31)
  Sheets("FINAL AWARD").Range("A1:K1").Copy ActiveSheet.Range("A1")
  Range("A2").Select
  Do While Selection <> ""
  ActiveCell.Offset(1, 0).Activate
  Loop
  rng1.Copy ActiveCell
  Set rng1 = rng1.Offset(1, 0)
  Set rng = rng.Offset(1, 0)
  End If
vrb = False
Loop
End Sub

 

[Luke M]

Modified code starting at line 28:

Sub Splitdatatosheets()

Application.ScreenUpdating = False

Dim rng As Range
Dim rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Set rng = Sheets("FINAL AWARD").Range("K2")
Set rng1 = Sheets("FINAL AWARD").Range("A2:K2")
vrb = False
Do While rng <> ""
  For Each sht In Worksheets
  If sht.Name = Left(rng.Value, 31) Then
  sht.Select
  Range("A1").Select
  Do While Selection <> ""
  ActiveCell.Offset(1, 0).Activate
  Loop
  rng1.Copy ActiveCell
  ActiveCell.Offset(1, 0).Activate
  Set rng1 = rng1.Offset(1, 0)
  Set rng = rng.Offset(1, 0)
  vrb = True
  End If
  Next sht
  If vrb = False Then
  'XXXXXX
  'New code lines
  Sheets("FINAL AWARD").Range("A1:K1").Copy 'This creates a new workbook
  ActiveSheet.Name = Left(rng.Value, 31)
  ThisWorkbook.Activate 'Go back to original workbook
  'XXXXXXX
  Range("A2").Select
  Do While Selection <> ""
  ActiveCell.Offset(1, 0).Activate
  Loop
  rng1.Copy ActiveCell
  Set rng1 = rng1.Offset(1, 0)
  Set rng = rng.Offset(1, 0)
  End If
vrb = False
Loop
End Sub

 

[Maria Clara]

Hi Luke, thanks !! I've just tested the code and it is still splitting the data on same spreadsheet and now the spreadsheet data are being duplicated after I run the code in each new sheet. Would you mind taking another look at the code?

thanks again!

 

[Luke M]

Would you be able to provide an example workbook? In the code there are a few other places where a .Copy is being called, but I don't know what all is being moved around exactly.

 

[Maria Clara]

Please find the link for the file! Thanks a lot !!!

http://www.sendspace.com/file/u8n1rr

 

[Luke M]

Afraid I can't access outside files . Can you upload directly to the forum thread?

 

[Maria Clara]

Sorry, Luke! Here you go !!! thanks again.

 

[Luke M]

Hi Maria,

I use the technique from Ron at this page:
http://www.rondebruin.nl/win/s3/win006_3.htm

And it seems to work wonderfully. Ron's macro is fully commented, so you should be all set.

 

[Maria Clara]

Luke, thank you so much .. It is just perfect!

Quick question: Some of the values on column 11 might sometimes have invalid characters, I've found the code below online but I'm not sure where I should include this on the code you gave me. Can you shed a light on this please?

Sub Query()
WkbName =ActiveCell.Value
MyArray = Array("<", ">", "|", "/", "*", "\", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
WkbName = Replace(WkbName, MyArray(X), "_", 1)
Next X
MsgBox WkbName
End Sub

 

[Luke M]

We'll change the code you found to a function:

Function Query(WbkName As String)
'Given to use already
'WkbName = ActiveCell.Value
MyArray = Array("<", ">", "|", "/", "*", "\", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
WkbName = Replace(WkbName, MyArray(X), "_", 1)
Next X
'Spit the new clean name back out:
Query = WbkName
End Function

Then, in the macro I gave you, first add a Dim statement at the top of macro for:

Dim cleanName As String

Then, scroll down to line 132. We'll change edit the name before attempting a save, like so:

'Begin of new edits
                On Error Resume Next
                cleanName = Query(cell.Value)
                WSNew.Parent.SaveAs foldername & _
                                    cleanName & FileExtStr, FileFormatNum
                If Err.Number > 0 Then
                    Err.Clear
                    ErrNum = ErrNum + 1

                    WSNew.Parent.SaveAs foldername & _
                     "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum

                    .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
                      "Error_" & Format(ErrNum, "0000") & FileExtStr & """)"

                    .Cells(cell.Row, "A").Interior.Color = vbRed
                Else
                    .Cells(cell.Row, "B").Formula = _
                    "=Hyperlink(""" & foldername & cleanName & FileExtStr & """)"
                End If
'End of edits