Macro to insert a row after every change in value and copying the data into new sheets

[rakesh933]

Hey All

I'm am trying to figure out a macro to run that:

I want to insert a row after every change in cell value in column W and copy the Separated data into new sheets.
Ex:

Column w

A
A
A
A
B
B
B
B
C
C
C
C

i want all the a separator between A,B,and C and all the corresponding data of A,b, and c into different sheets with respective lables.

Thanks

 

[pboltonchina]

Try this on a copy of you data

Option Explicit


Sub AddBreaks()
Dim LR As Long
Dim Rw As Long


LR = Range("A" & Rows.Count).End(xlUp).Row 'change to column containing data


For Rw = LR - 1 To 2 Step -1
If Range("A" & Rw) <> Range("A" & Rw + 1) Then _
Range("A" & Rw + 1).EntireRow.Insert xlShiftDown
Next Rw


End Sub

 

[rakesh933]

Not Quite ...
i got the below code to separate the data with every change in Value in desired column.

i wanna loop the copy paste of the separated data into different sheets.

Sub ins_row()
Dim Lst As Long
Dim n As Long
Lst = Range("W" & Rows.Count).End(xlUp).Row
For n = Lst To 2 Step -1
With Range("W" & n)
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(1).Insert
End If

End With
Next n
End Sub

 

[pboltonchina]

This will put all your data in separate sheets. Try on a copy of your data

Option Explicit


Sub ParseItems()
'Author: Jerry Beaucaire
'Date: 11/11/2009
'Summary: Based on selected column, data is filtered to individual sheets
' Creates sheets and sorts sheets alphabetically in workbook
' 6/10/2010 - added check to abort if only one value in vCol
' 7/22/2010 - added ability to parse numeric values consistently
' 11/16/2011 - changed way Unique values are collected, no Adv Filter


Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long


Application.ScreenUpdating = False


'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1

'Sheet with data in it
Set ws = Sheets("Data")


'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row


'Spot bottom row of data
LR = ws.Cells(ws.Rows.count, vCol).End(xlUp).Row


'Get a temporary list of unique values from vCol
iCol = ws.Columns.count
ws.Cells(1, iCol) = "key"

For Itm = 2 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))


'clear temporary list
ws.Columns(iCol).Clear


'Turn on the autofilter
ws.Range(vTitles).AutoFilter


'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""

If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(after:=Worksheets(Worksheets.count)).Name = MyArr(Itm) & ""
Else 'clear sheet if it exists
Sheets(MyArr(Itm) & "").Move after:=Sheets(Sheets.count)
Sheets(MyArr(Itm) & "").Cells.Clear
End If

ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy _
Sheets(MyArr(Itm) & "").Range("A1")

ws.Range(vTitles).AutoFilter Field:=vCol
MyCount = MyCount + Sheets(MyArr(Itm) & "").Range("A" & Rows.count) _
.End(xlUp).Row - Range(vTitles).Rows.count
Sheets(MyArr(Itm) & "").Columns.AutoFit
Next Itm

'Cleanup
ws.AutoFilterMode = False
ws.Activate
MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"


Application.ScreenUpdating = True
End Sub