Need help with code splitting data to sheets

S

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
155
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I found a code that splits data into multiple sheets based on a key column but there is a line "ws.Cells(1, iCol) = "Unique"" which after the code runs, this word appears in cell XFD1. Without breaking the code like i know i'll do, how can i add a clean up to the code to remove "Unique" after the code is done running? Thanks!

VBA Code: 
Sub Split_to_Sheets()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim iCol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If

Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
ws.Columns(iCol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
After this line:
Application.DisplayAlerts = True

Add this line:
ws.Cells(1, iCol).clear
 
Upvote 0
DanteAmor said:
After this line:
Application.DisplayAlerts = True

Add this line:
ws.Cells(1, iCol).clear
Click to expand...
I gave that a shot but it didn't work. The original data was split into 4 sheets and each of the 4 sheets show "Unique" in XFD1. I was thinking adding a line of find/replace exact match of "Unique" but either my code wasn't good, i didn't put it in the right place (have it after the DisplayAlerts line) or something else but I put it below along with where i have it.

It also seems like Unique only appears if the user selects the entire header row. If you manually select the range of cells, it doesn't. Not sure if that ties into anything.

VBA Code: 
ws.Activate
Application.DisplayAlerts = True
Cells.Replace What:="Unique", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
 
Upvote 0
I give you another macro, the following one doesn't need a helper sheet or helper column to get the unique values.

VBA Code: 
Sub create_worksheets()
  Dim sh As Worksheet
  Dim vcol As Long, vrow As Long
  Dim title As String
  Dim c As Range, xTRg As Range, xVRg As Range
  Dim ky As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  
  On Error Resume Next
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Cells(1).Column
    vrow = xTRg.Cells(1).Row
    title = xTRg.AddressLocal
  On Error GoTo 0
  
  
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(sh.Cells(vrow + 1, vcol), sh.Cells(Rows.Count, vcol).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range(title).AutoFilter vcol, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Copy Range("A" & vrow)
      ActiveSheet.Columns.AutoFit
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
 
Upvote 0
DanteAmor said:
I give you another macro, the following one doesn't need a helper sheet or helper column to get the unique values.

VBA Code: 
Sub create_worksheets()
  Dim sh As Worksheet
  Dim vcol As Long, vrow As Long
  Dim title As String
  Dim c As Range, xTRg As Range, xVRg As Range
  Dim ky As Variant
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  On Error Resume Next
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Cells(1).Column
    vrow = xTRg.Cells(1).Row
    title = xTRg.AddressLocal
  On Error GoTo 0
 
 
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(sh.Cells(vrow + 1, vcol), sh.Cells(Rows.Count, vcol).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
   
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range(title).AutoFilter vcol, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Copy Range("A" & vrow)
      ActiveSheet.Columns.AutoFit
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
Click to expand...
Thank you! That there is a thing of beauty. The file i was using is 12560 rows and 133 columns. The code I was using, I considered fast for the size which ran about 26 seconds. This code is instantaneous at 2 seconds.

The only items i did note would be the old code did allow for navigation when the code starts. Meaning if you are anywhere in the worksheet and run the code, you can scroll to find and select the row/column needed. This one freezes the screen so the only way to navigate if the column is elsewhere in the sheet is to cancel out of the code and start over.

The other item is that the other code did highlight the row/column with a border as you select it so that you have a visual the row/column was selected. This one is completely minor and nit picky.

All in all though, I am impressed with how blazing fast the sheets are created!
 
Upvote 0
Serafin54 said:
The only items i did note would be the old code did allow for navigation when the code starts. Meaning if you are anywhere in the worksheet and run the code, you can scroll to find and select the row/column needed. This one freezes the screen so the only way to navigate if the column is elsewhere in the sheet is to cancel out of the code and start over.
Click to expand...

I adjusted the code so you don't have that problem.
VBA Code: 
Sub create_worksheets()
  Dim sh As Worksheet
  Dim vcol As Long, vrow As Long
  Dim title As String, cad As String
  Dim c As Range, xTRg As Range, xVRg As Range
  Dim ky As Variant
  
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  
  On Error Resume Next
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Cells(1).Column
    vrow = xTRg.Cells(1).Row
    title = xTRg.AddressLocal
  On Error GoTo 0
  cad = title & "," & xVRg.Address
  Range(cad).Select
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
    
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(sh.Cells(vrow + 1, vcol), sh.Cells(Rows.Count, vcol).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range(title).AutoFilter vcol, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Copy Range("A" & vrow)
      ActiveSheet.Columns.AutoFit
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
 
Upvote 0
Solution
DanteAmor said:
I adjusted the code so you don't have that problem.
VBA Code: 
Sub create_worksheets()
  Dim sh As Worksheet
  Dim vcol As Long, vrow As Long
  Dim title As String, cad As String
  Dim c As Range, xTRg As Range, xVRg As Range
  Dim ky As Variant
 
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  On Error Resume Next
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Cells(1).Column
    vrow = xTRg.Cells(1).Row
    title = xTRg.AddressLocal
  On Error GoTo 0
  cad = title & "," & xVRg.Address
  Range(cad).Select
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
   
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range(sh.Cells(vrow + 1, vcol), sh.Cells(Rows.Count, vcol).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
   
    For Each ky In .Keys
      On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
      sh.Range(title).AutoFilter vcol, ky
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Copy Range("A" & vrow)
      ActiveSheet.Columns.AutoFit
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
Click to expand...

PERFECTION!!! Still can't get over how much faster this code is compared to the one i had been using. Thank you very much.

if i'm not mistaken it is this code that was added along with the cad As String statement.

cad = title & "," & xVRg.Address
Range(cad).Select

can you please tell me what that does?
 
Upvote 0
Serafin54 said:
PERFECTION!!! Still can't get over how much faster
Click to expand...
The big difference is that the key lookup is done in memory with the dictionary. (y)


Serafin54 said:
cad = title & "," & xVRg.Address
Range(cad).Select

can you please tell me what that does?
Click to expand...


With these lines you only establish which is the row and which is the row. But they are not "selected" on the sheet.
VBA Code: 
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)

So, with the following, the row and column are concatenated, then selected on the sheet:
VBA Code: 
  cad = title & "," & xVRg.Address
  Range(cad).Select
 
Upvote 0
DanteAmor said:
The big difference is that the key lookup is done in memory with the dictionary. (y)





With these lines you only establish which is the row and which is the row. But they are not "selected" on the sheet.
VBA Code: 
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)

So, with the following, the row and column are concatenated, then selected on the sheet:
VBA Code: 
  cad = title & "," & xVRg.Address
  Range(cad).Select
Click to expand...

awesome. Thank you very much!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
111
Scifo
S
S
  • Question
VBA code_How to keep in Excel header row included when splitting worksheet to separate worksheets
Replies
1
Views
662
rlv01
R
M
  • Question
Need to keep data only for one cell value.
Replies
0
Views
442
MDMitch
M
S
  • Solved
VBA Parse Data. (do not want title to copy over Every time)
Replies
2
Views
471
Scifo
S
S
  • Solved
Parse Data - Paste Range to new sheets as values only.
Replies
9
Views
570
Scifo
S

Forum statistics

Threads
1,214,606
Messages
6,120,492
Members
448,967
Latest member
visheshkotha

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top