Split data into multiple sheets based on column - excel

Question

#Modifying Question for better understanding and how do i want the result is.
Wizhi answer almost matched for my question !! But need some more
changes in his answer because which code is not working for me !! And
no need to work based on GCN Date as he answered. The split work
done based on Destination Pincode .
Please help someone help me to Macro Code for Split data into multiple sheet within an excel workbook based on a table format. Below is the explanation of how i have done as per my knowledge and what is my expectation is !!
"Here is the workbooks what i have Done"
Please download the Macro_Folder and Unzip it in you "C" Drive.
Open Macro Workbook and Press Button to run macro.
If it asked for updating formulas as shown in below picture please select "Don't Update" to continue macro.
My Macro workbook view :
I Have done button option to Run the split macro in separate excel workbook.
Where the files Located
When self open and run Macro from Macro Workbook it automatically opens my XD MIS Report and start formatting and split the date into multiple sheets.
View of XD MIS is "Master Data" which is having overall raw data.
Here is the view after self Run Macro fro split Master data.
Code that i Used For Split Data into Multiple Sheet:
Sub Spli_Data()
Dim wb As Workbook
Dim myfilename As String
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
myfilename = "C:\Macro\XD MIS Report.xlsx"
Set wb = Workbooks.Open(myfilename)
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
Columns("B:F").Select
Range("B2").Activate
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Range("H2").Activate
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Range("K2").Activate
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Range("D2").Activate
Selection.Cut
Selection.End(xlToRight).Select
Columns("K:K").Select
Range("K2").Activate
Selection.Insert Shift:=xlToRight
Selection.End(xlUp).Select
Range("K1").Select
ActiveCell.FormulaR1C1 = "Remarks"
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H1").Select
ActiveCell.FormulaR1C1 = "Packing Type"
Range("H1").Select
Selection.End(xlToLeft).Select
Cells.Select
Selection.FormatConditions.Delete
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-1]C[6]:RC[6],RC[6])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R1C7:RC[6],RC[6])"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Columns("A:A").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Range("A1:L3100").Select
Range("A2").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri Light"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("A2").Select
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 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
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Result Of Split Data What i have right now:
Destination 1
Destination 2
Now Let's Clear About My Requirement:
I have done macro for format and Split Data into multiple Sheet,But this the not exact format result which i'm looking for.
The split should be done in same method but for result format should be like below formats based on macro code.
The split data should be in Multiple sheets of within an Excel Workbook . Not split to multiple workbooks !!
Write a macro for split Data in this format for all Destination Pincode:
This how i'm expecting final result through macro code
Expected Format of #Destination 1 Sample After Split done
#Destination 1 Sample
This is an examples of what i'm looking for. The same have to done
for all destination which is in Master Data
Hope !! now my question is clear for better understanding and easy to answer.

Answer 1

Updated code:
#Mark Balhoff, Thanks for your valuable input, I always like to learn and get feedback to improve myself :). I have used your input in the code and also extended it a bit.
This code is using dictionary so you need to activate "Microsoft Scripting Runtime"
"Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
User process to split Master Data:
I assume that the user will split this data in the picture:
Pressing the button, it will choose column 7.
(My opinion is that this part with InputBox etc... is unnecessary as you always want to filter by column 7 regardless, so I feel it confused the end user)
Is quite unclear from what "raw data" you start with as new pictures/data have appeared in the updated question. I have assumed that the data that we should split looks like this, as it was stated first
Output of the first unique Destination Pincode:
Output of the second unique Destination Pincode:
Code:
Option Explicit
Sub Split()
Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet
Dim DestPincode As Range
Dim DestPincodeCol As Long
Dim vcol As Long
Dim vcol_value As String
Dim vcol_name As String
Dim vcol_prompt As String
Dim i As Integer
Dim DestPincode_ws_new As Range
Dim DestPincodeCol_ws_new As Long
Dim DestPincodeRow_ws_new As Long
Application.ScreenUpdating = False
'##### SETTINGS #####
Set ws = ActiveWorkbook.Worksheets("Master_Data") 'Set master data sheet
Set DestPincode = ws.Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
'####################
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Find last column in Master Data
DestPincodeCol = DestPincode.Column 'Get column number for Destination Pincode
lr = ws.Cells(ws.Rows.Count, DestPincodeCol).End(xlUp).Row 'Get last row
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
'##### Filter based on InputBox #####
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="7", Type:=1)
If vcol <> 7 Then Exit Sub
'##### Get all the uniqe "Destination Pincodes" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim DestPincodeData()
Dim UniqueDestPincodeData As Object
Dim DestPinRow As Long
Set UniqueDestPincodeData = CreateObject("Scripting.Dictionary")
DestPincodeData = Application.Transpose(ws.Range(ws.Cells(1, DestPincodeCol), ws.Cells(ws.Cells(Rows.Count, DestPincodeCol).End(xlUp).Row, DestPincodeCol))) 'Get all the Destination Pincode values
For DestPinRow = 2 To UBound(DestPincodeData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
UniqueDestPincodeData(DestPincodeData(DestPinRow)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Destination Pincodes and add to seperate workbooks #####
Dim new_wb As Workbook
Set new_wb = Application.Workbooks.Add 'Add new workbook
'Set new_wb = ActiveWorkbook
Dim DestPincodeName As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Filter range 'Set filter range
For Each DestPincodeName In UniqueDestPincodeData.Keys 'Filter through all the unique names in dictionary "UniqueDestPincodeData"
'Debug.Print "Destination Pincode: " & DestPincodeName 'Print current unique Destination Pincode name
'Filter the data based on "Destination Pincode" and Column from InputBox
With MyRangeFilter
.AutoFilter Field:=DestPincodeCol, Criteria1:=DestPincodeName, Operator:=xlFilterValues 'Filter on Destination Pincode
End With
'##### Create new workbook for the filtered data #####
'To add to new worksheet:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = DestPincodeName
Set ws_new = new_wb.Worksheets(DestPincodeName)
'##### Create template in the new workbook #####
'Building template output, row by row
ws_new.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("*******", "TRIP NO", "TRIP DATE/TIME", "TRUCKTYPE (OWN/ATT/ADHOC)", "SEAL #", "SUPERVISOR NAME", "REMARK"))
ws_new.Range("H2:H6").Value = WorksheetFunction.Transpose( _
Array("VEHICLE NO", "VEHICLE CAPACITY", "DRIVER NAME", "DRIVER NO", "VENDOR NAME"))
Dim Top_Area_Cell_Format As Range
Set Top_Area_Cell_Format = ws_new.Range("A1:L1,A7:L7,A2:D2,E2:G2,H2:I2,J2:L2," _
& "A3:D3,E3:G3,H3:I3,J3:L3,A4:D4,E4:G4,H4:I4," _
& "J4:L4,A5:D5,E5:G5,H5:I5,J5:L5,A6:D6,E6:G6,H6:I6,J6:L6")
Application.DisplayAlerts = False
Top_Area_Cell_Format.Merge 'Merge cells
Top_Area_Cell_Format.HorizontalAlignment = xlLeft 'Make title in center
Top_Area_Cell_Format.Borders.LineStyle = xlContinuous 'Add border lines
Top_Area_Cell_Format.Font.Bold = True 'Add Bold text
ws_new.Range("A1:L1").HorizontalAlignment = xlCenter 'Make title in center
Application.DisplayAlerts = True
'##### Paste filtered data from Master_Data sheet #####
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter 'Make text in center
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).EntireRow.Copy 'Copy entire row from filtered data
ws_new.Cells(8, "A").PasteSpecial xlPasteAll 'Paste all values including formats
Set DestPincode_ws_new = ws_new.Range(ws_new.Cells(8, 1), ws_new.Cells(1, ws_new.Cells(8, ws_new.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
DestPincodeCol_ws_new = DestPincode_ws_new.Column
DestPincodeRow_ws_new = ws_new.Cells(ws_new.Rows.Count, DestPincodeCol_ws_new).End(xlUp).Row
'Add total
ws_new.Cells(DestPincodeRow_ws_new + 1, "A").Value = "TOTAL"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Merge 'Merge cells
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).HorizontalAlignment = xlCenter 'Make text in center
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Font.Bold = True 'Add Bold text
'Add total values
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "I"), ws_new.Cells(DestPincodeRow_ws_new + 1, "I")).Formula = "=SUM(I9:I" & DestPincodeRow_ws_new & ")" 'Add sum for "No. of cartons"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "J"), ws_new.Cells(DestPincodeRow_ws_new + 1, "J")).Formula = "=SUM(J9:J" & DestPincodeRow_ws_new & ")" 'Add sum for "Actual weights"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Font.Bold = True 'Add Bold text
'##### Add sign boxes #####
Dim Bottom_Area_Cell_Text_Rng As String
Dim Bottom_Area_Cell_Format As String
Dim Bottom_Area_Cell_Format_rng As Range
Bottom_Area_Cell_Text_Rng = "B" & DestPincodeRow_ws_new + 2 & ":H" & DestPincodeRow_ws_new + 2
ws_new.Range(Bottom_Area_Cell_Text_Rng).Value = Array("Driver Signature", "", "Incharge Signature", "", "Security Signature", "", "REMARK")
Bottom_Area_Cell_Format = "A" & DestPincodeRow_ws_new + 2 & ":A" & DestPincodeRow_ws_new + 4 & "," _
& "B" & DestPincodeRow_ws_new + 2 & ":C" & DestPincodeRow_ws_new + 4 & "," _
& "D" & DestPincodeRow_ws_new + 2 & ":E" & DestPincodeRow_ws_new + 4 & "," _
& "F" & DestPincodeRow_ws_new + 2 & ":G" & DestPincodeRow_ws_new + 4 & "," _
& "H" & DestPincodeRow_ws_new + 2 & ":L" & DestPincodeRow_ws_new + 4
Set Bottom_Area_Cell_Format_rng = ws_new.Range(Bottom_Area_Cell_Format)
Application.DisplayAlerts = False
Bottom_Area_Cell_Format_rng.Merge 'Merge cells
Bottom_Area_Cell_Format_rng.HorizontalAlignment = xlLeft 'Make title in center
Bottom_Area_Cell_Format_rng.Borders.LineStyle = xlContinuous 'Add border lines
Bottom_Area_Cell_Format_rng.VerticalAlignment = xlTop 'Alignment of text
Bottom_Area_Cell_Format_rng.Font.Bold = True 'Add Bold text
Application.DisplayAlerts = True
'Adjust Column width
ws_new.Columns("A:L").Select
Selection.EntireColumn.AutoFit
Set ws_new = Nothing 'Reset worksheet value
Next
Application.DisplayAlerts = False
new_wb.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheet1.ShowAllData 'remove filter
On Error GoTo 0
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Link to workbook:
https://www.dropbox.com/s/86wlv99y6wylpn8/split%20data.xlsm?dl=0

Answer 2

I'm not sure If I've understand properly, but it looks like you want to split your data depending on the value of PINCODE column.
Besides, your question is too broad right now, you should focus more.
So, as example, I understand you would select all rows containing PINCODE=PUZHAL, and copy all of them into a different workbook.
And you want this for each unique PINCODE.
I made a fake dataset coloring rows, and I split the data into new workbooks. You'll need to adapt this to paste the data into existing workbooks (or new worksheets of same workbook, whatever)
My data is like this:
My code:
Sub TEST()
Application.ScreenUpdating = False
Dim MyDict As Object
Dim i As Long
Dim MyKey As Variant
Dim LR As Long
Dim WB As Workbook
Dim MyRows As Variant
LR = Range("G" & Rows.Count).End(xlUp).Row
Set MyDict = CreateObject("Scripting.Dictionary")
For i = 2 To LR Step 1
If MyDict.Exists(Range("G" & i).Value) = False Then
'we create the PINCODE in Dictionary and assign row number
MyDict.Add Range("G" & i).Value, i
Else
'PINCODE already in Dictionary, we add the new row number
MyDict(Range("G" & i).Value) = MyDict(Range("G" & i).Value) & "|" & i
End If
Next i
'now Dictionary holds all pincodes and all row numbers for each pincode.
'we create a workbook for each PINCODE, but you can adapt this to open a exact workbook depending on PINCODE
'I'm copying the rows starting at row 1, but you can adapt this to your model for sure
For Each MyKey In MyDict.Keys
Set WB = Application.Workbooks.Add
LR = 1 'change this to starting row
MyRows = Split(MyDict(MyKey), "|") 'we create array of rows numbers
For i = LBound(MyRows) To UBound(MyRows) Step 1
'we copy range A:L from that row into destiny workbook
ThisWorkbook.ActiveSheet.Range("A" & MyRows(i) & ":L" & MyRows(i)).Copy WB.ActiveSheet.Range("A" & LR & ":L" & LR)
LR = LR + 1 'we increase LR so next data will be pasted into next row
Next i
Erase MyRows
Set WB = Nothing
DoEvents
Next MyKey
MyDict.RemoveAll
Set MyDict = Nothing
Application.ScreenUpdating = True
End Sub
And this is how i get all my data splitted into different files depending on PINCODE.

Answer 3

I suggest You create a Pivot Table.
By that Pivot table you create a code to extract data on a pivotable base on a list and transfer that to the formatted workbook you created and make a loop until the last Destination Pincode. I also use Excel VBA Form to Trigger this. I can make you one if you post your Excel here.

Answer 4

I've created a macro that transfers the selected value from the dropdown list to the sheet with the same name as the value. I recommend that you review it.
Source : Split data into multiple sheets