Related:
- Vba code to conditionally copy the data
- A VBA code to conditionally copy data from one sheet to another - How-To - Excel
- Vba code to copy and paste data from one workbook to another - How-To - Excel
- Vba code to search data in excel - How-To - Excel
- Excel - VBA code for deleting data in row while keeping formulas - How-To - Excel
- Need vba Code to Transfer Data from Sheet3 to Row1 of Sheet2? ✓ - Forum - Excel
9 replies
Best answer
- Posts
- 368
- Registration date
- Monday February 7, 2011
- Status
You can use following codes
Sub SplitSheets()
Dim DataSht, wsCrit, SplitSht As Worksheet
Dim lrUnq, lrData, I As Long
Dim FtrVal As String
Application.ScreenUpdating = False
Set DataSht = Worksheets("sheet1") 'change it to the name of your raw data sheet
lrData = DataSht.Range("a" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
DataSht.Range("B1:l" & lrData).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsCrit.Range("A1"), Unique:=True
lrUnq = wsCrit.Range("a" & Rows.Count).End(xlUp).Row
For I = 2 To lrUnq
FtrVal = wsCrit.Range("A" & i).Value
Set SplitSht = Worksheets.Add
DataSht.Select
'DataSht.ShowAllData
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range("A1:Z" & lrData).AutoFilter Field:=2, Criteria1:=FtrVal
Range("a1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
SplitSht.Select
Range("A1").Select
ActiveSheet.Paste
'Cells.Select
Cells.EntireColumn.AutoFit
SplitSht.Name = FtrVal
Application.CutCopyMode = False
Next i
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
.AutoFilterMode = False
End Sub
Sub SplitSheets()
Dim DataSht, wsCrit, SplitSht As Worksheet
Dim lrUnq, lrData, I As Long
Dim FtrVal As String
Application.ScreenUpdating = False
Set DataSht = Worksheets("sheet1") 'change it to the name of your raw data sheet
lrData = DataSht.Range("a" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
DataSht.Range("B1:l" & lrData).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsCrit.Range("A1"), Unique:=True
lrUnq = wsCrit.Range("a" & Rows.Count).End(xlUp).Row
For I = 2 To lrUnq
FtrVal = wsCrit.Range("A" & i).Value
Set SplitSht = Worksheets.Add
DataSht.Select
'DataSht.ShowAllData
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range("A1:Z" & lrData).AutoFilter Field:=2, Criteria1:=FtrVal
Range("a1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
SplitSht.Select
Range("A1").Select
ActiveSheet.Paste
'Cells.Select
Cells.EntireColumn.AutoFit
SplitSht.Name = FtrVal
Application.CutCopyMode = False
Next i
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
.AutoFilterMode = False
End Sub
A few words of thanks would be greatly appreciated. Add comment
4333 users have said thank you to us this month
hi please use the this link to get the raw file " http://speedy.sh/RJs2g/pending-raw.xls "
he data it contain is different then I asked but the logic is same.I need all the data in sheet1 will be copied to the sheet2,sheet3 and so on according to the "Group" in sheet1..
the sheet attached is without macro.
thank you
sunny.
he data it contain is different then I asked but the logic is same.I need all the data in sheet1 will be copied to the sheet2,sheet3 and so on according to the "Group" in sheet1..
the sheet attached is without macro.
thank you
sunny.
- Posts
- 2448
- Registration date
- Sunday September 12, 2010
- Status
Good one Sunny,
I meant for you to change the sheet names.
But since I had some spare time (and I am a kind person) I did it for you.
Here is the code:
And here is your file with code:
http://speedy.sh/acm4R/Sunny-pending-raw.xls
Best regards,
Trowa
I meant for you to change the sheet names.
But since I had some spare time (and I am a kind person) I did it for you.
Here is the code:
Sub MoveData()
Dim lRow As Integer
lRow = Range("A" & Rows.Count).End(xlUp).Row
Sheets("raw").Activate
For Each cell In Range("F2:F" & lRow)
cell.EntireRow.Copy
Sheets(cell.Value).Activate
Range("B" & Rows.Count).End(xlUp).Offset(1, -1).PasteSpecial
Next cell
Application.CutCopyMode = False
End Sub
And here is your file with code:
http://speedy.sh/acm4R/Sunny-pending-raw.xls
Best regards,
Trowa
- Posts
- 2448
- Registration date
- Sunday September 12, 2010
- Status
Hi Sunny,
Good to see you like it :).
The adjusted code will check if a sheet already exists with the groups name. If not, a sheets is created with the missing groups name along with the format (first row header and column width of the first 6 columns.).
Here is the code:
And here is your file with code for your convenience:
http://speedy.sh/zvnTp/Sunny-pending-raw.xls
Kind regards,
Trowa
Good to see you like it :).
The adjusted code will check if a sheet already exists with the groups name. If not, a sheets is created with the missing groups name along with the format (first row header and column width of the first 6 columns.).
Here is the code:
Sub MoveData()
Dim lRow As Integer
lRow = Range("A" & Rows.Count).End(xlUp).Row
Sheets("raw").Activate
For Each cell In Range("F2:F" & lRow)
If Not SheetExists(cell.Value) Then
Sheets.Add
ActiveSheet.Name = cell.Value
Sheets("raw").Range("A1:F1").Copy
Sheets(cell.Value).Range("A1").PasteSpecial Paste:=xlPasteAll
Sheets(cell.Value).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
End If
cell.EntireRow.Copy
Sheets(cell.Value).Activate
Range("B" & Rows.Count).End(xlUp).Offset(1, -1).PasteSpecial
Next cell
Application.CutCopyMode = False
End Sub
Function SheetExists(SheetName As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function
And here is your file with code for your convenience:
http://speedy.sh/zvnTp/Sunny-pending-raw.xls
Kind regards,
Trowa
- Posts
- 14
- Registration date
- Thursday February 2, 2012
- Last seen
- June 4, 2012
-but this is showing error called "invalid and unqualified" and also please let me know where we can set the condition?