Hello,
What shall I do to be able to separate data by each owner ?
For Example see original data export from system, I need to remove unwanted columns and then separate each data by owner as you can see in second photo.
Please advise shall I use Pivot Table, VLookup, or Micro ? and How can I use them ?
Re: Separate data from each owner into separate sheet?
Xani,
Here is an example where I filter data based on Column A (Column 1) based on certain names and then move the data to the respective worksheet. You can probably use this as a base and modify it as needed....
'=========================================================================='
'=========================================================================='
'Module Type: Code Module '
'Purpose : Filter data and paste to corresponding worksheets '
'=========================================================================='
'Author : Matt Mickle ' '
'Date : 07.20.2017 '
'=========================================================================='
Sub FilterAndPlaceData()
'Declarations
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Dim arrShts() As Variant
Dim shtLp As Integer
Dim filterCol As Integer
Dim lcol As Integer
Dim lrow As Integer
Set shtSource = Sheets("All AEs") 'Define source worksheet
arrShts = Array("Ditas", "Eric", "John", "Leslie", "Neil", "Shera", "Tim") 'Define destination worksheet names
filterCol = 1 'Define Column to filter on....
With shtSource
shtSource.Activate 'Activate Sheet so filter will work properly
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column 'Define last column of source worksheet
lrow = .Cells(Rows.Count, "A").End(xlUp).Row 'Define last row of source worksheet
'Loop through names to filter on...
For shtLp = 0 To UBound(arrShts) - 1
Set shtDestination = Sheets(arrShts(shtLp))
With .Range(Cells(1, 1), Cells(lrow, lcol))
.AutoFilter filterCol, "=" & arrShts(shtLp) & "*" 'Filter on X Employee (Notice the asterisk as a wildcard)
.Offset(1).SpecialCells(xlCellTypeVisible).Copy shtDestination.Range("A2") 'Copy All Employee Data to Appropriate Worksheet
.AutoFilter 'UnFilter
End With
Next shtLp 'Go to Next Employee Name / Worksheet
End With
End SubRe: Separate data from each owner into separate sheet?
http://"http://www.ozgrid.com/forum/member.php?u=247596" mrmmickle1,
I am trying to apply the above code but I did not succeed, is it possible to share with me the template working with this code to understand it better?
Re: Separate data from each owner into separate sheet?
Xani
Pictures are of little value to those of us trying to help you. They are hard to read and we have no idea what comprises the data that is shown. Suggest you upload a sample workbook with a before and after scenario. In this manner, we can provide a working solution that is specific to your needs.
Re: Separate data from each owner into separate sheet?
AlanSidman,
I agree with u I try to upload photo but I dont know why size is small, Also I try to upload workbook but size is large !!
Re: Separate data from each owner into separate sheet?
Ok I try to decrease size of workbook, Please find attached file.
What I am planning to do is the following:
To take specific columns from the data sheet and transfer it to each owner sheet in the below.
Example: Engineering Department - User data owner data should be transfer to Engineering Department - User sheet.
Columns needed:
[TABLE="width: 1622"]
[TD="class: xl64, width: 98"]Work Order
[/TD]
[TD="class: xl64, width: 351"]Description
[/TD]
[TD="class: xl64, width: 64"]Work Type
[/TD]
[TD="class: xl64, width: 64"]WO Status
[/TD]
[TD="class: xl64, width: 166"]Name
[/TD]
[TD="class: xl64, width: 108"]Target Start[/TD]
[TD="class: xl64, width: 101"]Target Finish[/TD]
[TD="class: xl64, width: 108"]Scheduled Start[/TD]
[TD="class: xl64, width: 101"]Scheduled Finish[/TD]
[TD="class: xl64, width: 108"]Actual Start
[/TD]
[TD="class: xl64, width: 108"]Actual Finish
[/TD]
[TD="class: xl64, width: 108"]WOCreationDate
[/TD]
[TD="class: xl64, width: 76"]Record ID
[/TD]
[TD="class: xl64, width: 61"]IncStatus
[/TD]
[/TABLE]
Re: Separate data from each owner into separate sheet?
try this vba solution
Option Explicit
Sub FilterCopy()
Dim ws As Worksheet, s1 As Worksheet
Set s1 = Sheets("Sheet1")
Dim i As Long, lr As Long, lrw As Long
Dim owner As String
Application.ScreenUpdating = False
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lr
owner = s1.Range("H" & i)
Application.Union(s1.Range("A" & i & ":C" & i), s1.Range("E" & i), s1.Range("H" & i), s1.Range("V" & i & ":AC" & i), s1.Range("AE" & i)).Copy
lrw = Sheets(owner).Range("A" & Rows.Count).End(xlUp).Row
Sheets(owner).Range("A" & lrw + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Action Completed"
Next i
End SubRe: Separate data from each owner into separate sheet?
Dear All,
I try to apply the above but I did not successed, Is it possible for someone to help me on my excel sheet?
Re: Separate data from each owner into separate sheet?
I try to apply below code over my sheet, The problem is that it only copy the data of "OGA Shift - Department User" to separate sheet, but for "Mr Salman Hasan Alaradi" did not copy the data to his sheet, why is that happen?
Sorry I could not upload my excel file due to size exceed current size allowed to upload excel files.
Sub FilterAndPlaceData()
'Declarations
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Dim arrShts() As Variant
Dim shtLp As Integer
Dim filterCol As Integer
Dim lcol As Integer
Dim lrow As Integer
Set shtSource = Sheets("List of Work Orders") 'Define source worksheet
arrShts = Array("OGA Shift - Department User", "Mr Salman Hasan Alaradi") 'Define destination worksheet names
filterCol = 8 'Define Column to filter on....
With shtSource
shtSource.Activate 'Activate Sheet so filter will work properly
lcol = .Cells(8, Columns.Count).End(xlToLeft).Column 'Define last column of source worksheet
lrow = .Cells(Rows.Count, "A").End(xlUp).Row 'Define last row of source worksheet
'Loop through names to filter on...
For shtLp = 0 To UBound(arrShts) - 1
Set shtDestination = Sheets(arrShts(shtLp))
With .Range(Cells(1, 1), Cells(lrow, lcol))
.AutoFilter filterCol, "=" & arrShts(shtLp) & "*" 'Filter on X Employee (Notice the asterisk as a wildcard)
.Offset(1).SpecialCells(xlCellTypeVisible).Copy shtDestination.Range("A2") 'Copy All Employee Data to Appropriate Worksheet
.AutoFilter 'UnFilter
End With
Next shtLp 'Go to Next Employee Name / Worksheet
End With
ActiveWorkbook.RefreshAll 'Refresh All Pivot Tables in workbook
End SubRe: Separate data from each owner into separate sheet?
I do not understand what did not work with the code I supplied. It worked perfectly for me when I applied it to the sample workbook you supplied. When you say it does not work, that does not help me to diagnose what is your problem. Tell me specifically what happened and what did not happen. Did you get error messages? Did you place it in a new module? I am not a mind reader. Is your workbook not represented by what you supplied as a sample?
Re: Separate data from each owner into separate sheet?
Try this
Option Explicit
Sub SplitByOwner()
Dim x, y(), yy, k, i As Long, ii As Long, iii As Long, v As Integer, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
oDic.CompareMode = 1
x = Sheets("sheet1").Cells(1).CurrentRegion
For i = 2 To UBound(x, 1)
If Len(x(i, 8)) Then
k = oDic.Item(x(i, 8))
If IsEmpty(k) Then
For ii = 2 To UBound(x, 1)
If x(ii, 8) = x(i, 8) Then
v = v + 1: ReDim Preserve y(1 To 14, 1 To v)
For iii = 1 To 3
y(iii, v) = x(ii, iii)
Next
y(4, v) = x(ii, 5): y(5, v) = x(ii, 8): y(14, v) = x(ii, 31)
For iii = 6 To 13
y(iii, v) = x(ii, iii + 16)
Next
End If
Next
oDic.Item(x(i, 8)) = y
End If
End If
Erase y: v = 0
Next
yy = Array(oDic.keys, oDic.items)
For i = LBound(yy(0)) To UBound(yy(0))
With Sheets(yy(LBound(yy(0)))(i))
.Rows(2).Resize(.UsedRange.Rows.Count).Delete
.[a2].Resize(UBound(yy(1)(i), 2), 14) = Application.Transpose(yy(1)(i))
With .UsedRange.Offset(1)
.Columns(2).WrapText = True
.VerticalAlignment = -4108
End With
.Columns.AutoFit
End With
Next
MsgBox "Data successfully copied to Owner Sheets.", 64, "Completed"
End SubYour sample workbook with code added and working is attached.
Re: Separate data from each owner into separate sheet?
Hello,
You can test code below :
Sub SplitintoSheets()
Dim lastrow As Long, lastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheet1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
iStart = 2
For i = 2 To lastrow
If .Range("J" & i).Value <> .Range("J" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("J" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, lastCol)).Value = .Range(.Cells(1, 1), .Cells(1, lastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, lastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End SubAttached is your sample workbook
Hope this will help
Re: Separate data from each owner into separate sheet?
KjBox,
I checked your code with attached workbook, It worked with the current data, If i put the original data which it is a lot of rows it will highlight this code in yellow:
Carim,
Your code work , But I notice the following, After changing data with large data it will show additional sheets but without Project Manager Name, for example Sheet1, Sheet 2, Sheet 3 + The other problem is for example instead of having OGA Shift Department User in one sheet there is a lot of sheets differently but the owner is OGA Shift ! They should be all project manager same into one sheet , not separaetly.
For example
Project Manager A in one sheet
Project Manager B in one sheet
what happening is for example Project Manager A some rows and columns in one sheet, some of them in another sheets.
Re: Separate data from each owner into separate sheet?
Hello,
If you need the Owner to split use the Range("J") ...
But if you need the Project Manager ... you have to use the Range("H") ...
Sub SplitintoSheets()
Dim lastrow As Long, lastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheet1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
iStart = 2
For i = 2 To lastrow
If .Range("H" & i).Value <> .Range("H" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("H" & iStart).Value
On Error Goto 0
ws.Range(Cells(1, 1), Cells(1, lastCol)).Value = .Range(.Cells(1, 1), .Cells(1, lastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, lastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End SubHope this will help
Re: Separate data from each owner into separate sheet?
QuoteI checked your code with attached workbook, It worked with the current data, If i put the original data which it is a lot of rows it will highlight this code in yellow:
What is the error message you get?
Re: Separate data from each owner into separate sheet?
Try the attached version.
I have modified the code and included an additional sheet named "Template" which holds the Headers for new sheets that will be created for each Project Manager. Make sure you add that sheet to your actual file, it can be hidden if you prefer.
The code includes a Function to check if a Sheet already exists for a Project Manager, make sure you include that if you copy/paste the code to your actual file.
the modified code is
Option Explicit
Sub SplitByOwner()
Dim x, y(), kee, i As Long, ii As Long, iii As Long, iv As Long, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
oDic.CompareMode = 1
x = Sheets("sheet1").Cells(1).CurrentRegion
For i = 2 To UBound(x, 1)
If Len(x(i, 8)) Then
kee = oDic.Item(x(i, 8))
If IsEmpty(kee) Then
For ii = 2 To UBound(x, 1)
If x(ii, 8) = x(i, 8) Then
iv = iv + 1: ReDim Preserve y(1 To 14, 1 To iv)
For iii = 1 To 3
y(iii, iv) = x(ii, iii)
Next
y(4, iv) = x(ii, 5): y(5, iv) = x(ii, 8): y(14, iv) = x(ii, 31)
For iii = 6 To 13
y(iii, iv) = x(ii, iii + 16)
Next
End If
Next
oDic.Item(x(i, 8)) = y
End If
End If
Erase y: iv = 0
Next
Application.ScreenUpdating = 0
For Each kee In oDic.keys
If Not SheetExists(CStr(kee)) Then
Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = kee
End If
With Sheets(kee)
.Rows(2).Resize(.UsedRange.Rows.Count).Delete
.[a2].Resize(UBound(oDic.Item(kee), 2), 14) = Application.Transpose(oDic.Item(kee))
With .UsedRange.Offset(1)
.Columns(2).WrapText = True
.VerticalAlignment = -4108
End With
.Columns.AutoFit
End With
Next
Sheets("sheet1").Activate
Application.ScreenUpdating = 1
MsgBox "Data successfully copied to Owner Sheets.", 64, "Completed"
End Sub
Function SheetExists(sName As String) As Boolean
SheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End FunctionRe: Separate data from each owner into separate sheet?
Dear KjBox
Thank you for the attachment, I checked your workbook and I got the following yellow error message.
The steps I follow as the following:
I copy my original data and paste it into Sheet 1. (I did not change or remove the headers existed in Sheet 1).
Almost 8676 rows been pasted into Sheet 1.
After running Macro I found split done for Yahya Splited, OGA Shift Splited, Anoop showing Empty Form, the rest did not split).
After decreasing the amount of rows, it worked again.
Kindly advise if I did any wrong.
Note: I could not attach original data due to size limitation of website, even though after archive into Zip file still large as 2.67MB
Re: Separate data from each owner into separate sheet?
Sometimes using Application.Transpose to transpose an array when placing the array contents onto a sheet directly fails for no explicable reason!
This can be overcome by transposing the array before placing the array contents onto the sheet.
Try changing the code to this, there is a slight modification to the Sub and a new Function.
Option Explicit
Sub SplitByOwner()
Dim x, y(), z, kee, i As Long, ii As Long, iii As Long, iv As Long, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
oDic.CompareMode = 1
x = Sheets("sheet1").Cells(1).CurrentRegion
For i = 2 To UBound(x, 1)
If Len(x(i, 8)) Then
kee = oDic.Item(x(i, 8))
If IsEmpty(kee) Then
For ii = 2 To UBound(x, 1)
If x(ii, 8) = x(i, 8) Then
iv = iv + 1: ReDim Preserve y(1 To 14, 1 To iv)
For iii = 1 To 3
y(iii, iv) = x(ii, iii)
Next
y(4, iv) = x(ii, 5): y(5, iv) = x(ii, 8): y(14, iv) = x(ii, 31)
For iii = 6 To 13
y(iii, iv) = x(ii, iii + 16)
Next
End If
Next
oDic.Item(x(i, 8)) = y
End If
End If
Erase y: iv = 0
Next
Application.ScreenUpdating = 0
For Each kee In oDic.keys
If Not SheetExists(CStr(kee)) Then
Sheets("Template").Copy , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = kee
End If
z = TransposeArray(oDic.Item(kee))
With Sheets(kee)
.Rows(2).Resize(.UsedRange.Rows.Count).Delete
.[a2].Resize(UBound(z, 1), 14) = z
With .UsedRange.Offset(1)
.Columns(2).WrapText = True
.VerticalAlignment = -4108
End With
.Columns.AutoFit
End With
Next
Sheets("sheet1").Activate
Application.ScreenUpdating = 1
MsgBox "Data successfully copied to Owner Sheets.", 64, "Completed"
End Sub
Function SheetExists(sName As String) As Boolean
SheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Function TransposeArray(Arr As Variant) As Variant
Dim temp, a As Long, b As Long, i As Long, ii As Long
i = UBound(Arr, 2): ii = UBound(Arr, 1)
ReDim temp(1 To i, 1 To ii)
For a = 1 To i
For b = 1 To ii
temp(a, b) = Arr(b, a)
Next
Next
TransposeArray = temp
End FunctionRe: Separate data from each owner into separate sheet?
KjBox,
Thank you it worked perfectly, Just a simple question as I know it is separate by Project Manager Name, If I wanted to change it by myself to split by something else like for example WO Owner Name I should change which Line in Code ?
This is only for my knowledge since I want to learn lol.
Re: Separate data from each owner into separate sheet?
Currently the first part of the code is like this
For i = 2 To UBound(x, 1)
If Len(x(i, 8)) Then
kee = oDic.Item(x(i, 8))
If IsEmpty(kee) Then
For ii = 2 To UBound(x, 1)
If x(ii, 8) = x(i, 8) Then
iv = iv + 1: ReDim Preserve y(1 To 14, 1 To iv)
For iii = 1 To 3
y(iii, iv) = x(ii, iii)
Next
y(4, iv) = x(ii, 5): y(5, iv) = x(ii, 8): y(14, iv) = x(ii, 31)
For iii = 6 To 13
y(iii, iv) = x(ii, iii + 16)
Next
End If
Next
oDic.Item(x(i, 8)) = y
End If
End If
Erase y: iv = 0
Next
The Project Manager Name is in Column H of the worksheet (that is column index 8). To change to WO Owner Name the code will need to reference sheet column J, which is column Index 10.
You will need to change 4 lines of the code to split by WO Owner.
Change
to
and
to
and
to
Don’t have an account yet? Register yourself now and be a part of our community!