Cut rows into new sheet based on changing value in column

[owmyheadimtootall]

Hi, does anybody know how I could cut rows from a range of data based on a changing value in a column. I have a whole set of data within which column K represents Currency. Currently I have my data sorted by Currency then a line is inserted with every Currency change.

Set up as:
Range("k2").Select
Do Until ActiveCell = Empty And ActiveCell.Offset(1) = Empty
If ActiveCell <> ActiveCell.Offset(1) And ActiveCell <> Empty And ActiveCell.Offset(1) <> Empty Then
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2).Select
Else
ActiveCell.Offset(1).Select
End If
Loop

What I would prefer as the data is now so large is to copy all data below the change in currency to the next sheet as opposed to entering a row. Does anybody know how I could do this?

Thanks,
Adam

 

[cornflakegirl]

I would do this using the advanced filter.

Set up a sheet for each of your currencies. In cell A1 put the field header for your currency column. In cell A2 put the currency code for that currency.

Code is:

Sub FilterMacro()
 
Dim ws As Worksheet
 
For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then
        ws.Range("a4").CurrentRegion.Clear
        Sheets("Sheet1").Range("A1:B11").AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=ws.Range("A1:A2"), CopyToRange:=ws.Range("A4"), Unique:=False
     End If
Next ws
End Sub

Change "Sheet1" to whatever the sheet with the initial data is called, and A1:B11 to be your data range.

 

[cornflakegirl]

Okay - just to see if I could - here's code that sets up the currency sheets etc for you:

Sub FilterMacro()
 
Dim ws As Worksheet
Dim rCellCounter As Range
Dim sDataSheet As String
Dim sCurrencyField As String
Dim iCurrencyColumn As Integer
 
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sCurrencyField = "Currency" 'change this to the title of your currency field
iCurrencyColumn = 1 'change this to the column number of your currency column
 
'Delete any existing currency sheets
Application.DisplayAlerts = False
For Each ws In Worksheets
    If ws.Name <> sDataSheet Then ws.Delete
Next ws
Application.DisplayAlerts = True
 
'Create currency sheets
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "Temp"
Sheets(sDataSheet).Columns(iCurrencyColumn).AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:="", copyToRange:=Sheets("Temp").Range("A1"), Unique:=True
'must include criteriarange - advanced filter "remembers" the last settings
 
'Filter on to each sheet
For Each rCellCounter In Sheets("Temp").Range("A1").CurrentRegion
    If rCellCounter.Value <> sCurrencyField Then
        Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = rCellCounter.Value
        ws.Range("a1").Value = sCurrencyField
        ws.Range("a2").Value = rCellCounter.Value
        Sheets(sDataSheet).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
            criteriarange:=ws.Range("A1:A2"), copyToRange:=ws.Range("A4"), Unique:=False
        ws.Rows("1:3").Delete
    End If
Next rCellCounter
 
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
 
Sheets(sDataSheet).Activate 'just for aesthetics
 
End Sub