Copying specific rows from one sheet to another

[Chris]

I have data on a sheet. I want to find all rows with
specific criteria (containing "variable data" from Site
sheet) and copy it to a new sheet with the name
of "variable information", continue until there are no
more variables on Site sheet.

The whole row must be copied. Some of the data rows will
have 10 columns others will have 20, for the sake of
space I will only list 4 columns below.


The site data sheet will have 1-75 sites listed. Only
three are listed below.

Sorting column C is fine.

sample data

worksheet "Site" (variable data)
A1 = chs
A2 = dub.aaa
A3 = lvl

worksheet "Data" (data to be parsed)
A1 = blank
B1 = NEW
C1 = test.chs.aaa.org
D1 = FRANK

A2 = blank
B2 = old
C2 = test.LVL.aaa.org
D2 = FRANK lvl

A3 = blank
B3 = NEW
C3 = test4_cccc.dub.aaa
D3 = FRANK DUB

A4 = blank
B4 = new
C4 = test.lvl.aaa.org
D4 = FRANK lvl 2

(on through 2000 rows)

Output

worksheet named "chs"
A1 = blank
B1 = NEW
C1 = test.chs.aaa.org
D1 = FRANK

worksheet named "lvl"
A1 = blank
B1 = old
C1 = test.lvl.aaa.org
D1 = FRANK lvl

A2 = blank
B2 = new
C2 = test.lvl.aaa.org
D2 = FRANK lvl 2

worksheet named "dub.aaa"
A1 = blank
B1 = NEW
C1 = test4_cccc.dub.aaa
D1 = FRANK DUB

All values will be listed in the 3rd column and will be
distinguished names (DN) as listed above. Some of the
DN may just be "aaa.org" or just "org" though. Not
necessarily only three letters either may be
xxxxxxxxxxxxxxxxxxxxx-xxxx.xxxxxxxxxxx.xxx.xxx

may or may not have "."

Thank you!

Chris

 

[steve]

Chris,

Try something like this (not tested).
This should work from any sheet since no selection is being
done and all references are sheet designated. And it should
run pretty fast.
You may have to add a 'Case else' to handle the odd-balls.

Dim lrow as Long, x as Long, y as Long, ws as String

' find last row in "Site" sheet
lrow= Sheets("Site").Cells(Rows.COUNT, "C").End(xlUp).Row

For x =1 to lrow
Select Case Sheets("Site").Cells(x,3)
Case "test.chs.aaa.org"
ws = "chs"
Case "test.lvl.aaa.org"
ws = "lvl"
Case "test4_cccc.dub.aaa"
ws = "dub"
End Select

If x = 1 then
y = 1
else
y = Sheets(ws).Cells(Rows.COUNT, "C").End(xlUp).Row +1
End If

Sheets("Site").Rows(x).Copy _
destination:= Sheets(ws).Cells(y, 1)
Next

 

[Anders S]

Chris,

Below is a macro that I think does what you want.
The macro does an Autofilter on sheet Data, column C, for each identifier in
sheet Site, and copies the found rows to new worksheets.

Test data is in sheet Site:
A
1 chs
2 dub.aaa
3 lvl

and i sheet Data:

A B C D
1 NEW test.chs.aaa.org FRANK
2 old test.LVL.aaa.org FRANK lvl
3 NEW test4_cccc.dub.aaa FRANK DUB
4 new test.lvl.aaa.org FRANK lvl 2

HTH
Anders Silvén
GMT+1

'--------
Sub xyz()
Dim dataPoint As Range
Dim newWks As Worksheet
Dim sitePos As Range, siteCode As String

Application.ScreenUpdating = False

' insert top row on sheet Data for Autofilter headers
With Worksheets("Data")
.Rows(1).Insert
Set dataPoint = .Range("A1")
End With
dataPoint.Value = "x"
dataPoint.CurrentRegion.Rows(1).Value = "x"

' loop values in sheet Site, column A
Set sitePos = Worksheets("Site").Range("A1")
dataPoint.CurrentRegion.AutoFilter
Do
siteCode = sitePos.Value
dataPoint.AutoFilter Field:=3, Criteria1:="=*" & siteCode & "*",
Operator:=xlAnd
Set newWks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
newWks.Name = siteCode ' code will break here if sheet name already
exists
dataPoint.CurrentRegion.Copy Destination:=newWks.Range("A1")
newWks.Rows(1).Delete

Set sitePos = sitePos.Offset(1, 0)
If sitePos.Value = "" Then Exit Do
Loop

' delete Autofilter headers
Worksheets("Data").Rows(1).Delete

Application.ScreenUpdating = True
End Sub

'--------