Macro 2 Extract Data 2 Paste in New Wksht

[JP2R]

undefined

Each morning a spreadsheet is sent to various regional managers - The
person who generates this just creates another row - It is sorted by
date - and separated by an empty row.

So I may have two rows with column "A" as a date, "B" as a problem, "C"
as something else, "D" as a region...etc. Then a blank or empty row,
then the yesterday's section..there may have been 3 or 4 rows of
data...and so on...

So...what I have been doing manually is to search for the empty rows
and delete all but the last one...

Then I do an AutoFilter...

Then I sort Column "D" - Region - one region at a time ( I am
responsible for 15 or so ) once it's sorted for a specific region - I
select the entire series of rows pertaining to that region and copy and
paste to a separate worksheet in the same workbook for that region.

I wasn't sure where to start...I was trying to create a macro...one at
a time and then maybe I could put them altogether...and create one
complete macro...first to eliminate those empty rows..all but the last
one...

I would really appreciate any assistance anyone could offer...

 

[Dave Ramage]

Try this...

Sub SplitRegions()
'''Splits data on active sheet into separate sheets based on data in column D
' Only values in column D matching the list in columnA of Sheet "List" will
be coppied
Const cNumSourceColumns As Integer = 4

Dim rngRegionList As Range, rngR As Range, rngList As Range
Dim wsSource As Worksheet, wsDest As Worksheet
Dim lLastRow As Long

Set wsSource = ActiveSheet

'get last row in source sheet
lLastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
'sort the data by date, then problem
wsSource.Range("A1").Resize(lLastRow, cNumSourceColumns).Sort
key1:=wsSource.Range("A1"), key2:=wsSource.Range("B1"), header:=xlYes '
change 4 to required number of columns
'blank rows now sorted to bottom, so get new last row
lLastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
Set rngList = wsSource.Range("A1").Resize(lLastRow, cNumSourceColumns)

'find list of Regions to extract and loop through
Set rngRegionList =
ThisWorkbook.Sheets("List").Range("A1").Resize(ThisWorkbook.Sheets("List").Cells(ThisWorkbook.Sheets("List").Rows.Count, 1).End(xlUp).Row, 1)
For Each rngR In rngRegionList
rngList.AutoFilter field:=4, Criteria1:=rngR.Formula
Set wsDest = ActiveWorkbook.Worksheets.Add
wsDest.Name = rngR.Formula
rngList.Copy Destination:=wsDest.Range("A1")
Next rngR
wsSource.AutoFilterMode = False
End Sub

Cheers,
Dave

 

[JP2R]

I really appreciate this...wow!