Need Help in Copying a row from a spreadsheet to another by its value

[Benastros]

Hello,

I am working on a Excel document, and I am trying to copy data over that have a value to sheet.

For Example,

I have 7 colums starting from B3 to H3, and what I am trying to do is copy the rows based on location to that sheet. Each sheet will be named by location so for example, Houston will have a sheet named Houston, and I want to copy all the rows to the Houston sheet, and so forth with the other locations. I know I can manually copy and paste them over, but is there away to do this just by entering the location on the main sheet page, and have it go to the desired location. I Hope this makes sense.

Thanks,

Ben

[TABLE="class: outer_border, width: 500"]
<tbody>[TR]
[TD]Service Tag
[/TD]
[TD]Name
[/TD]
[TD]Date Received
[/TD]
[TD]Assigned to
[/TD]
[TD]Location
[/TD]
[TD]Model
[/TD]
[TD]Ticket
[/TD]
[/TR]
[TR]
[TD]12222
[/TD]
[TD]wsdt012
[/TD]
[TD]8/12/12
[/TD]
[TD]Bob Smith
[/TD]
[TD]Houston
[/TD]
[TD]E-6400
[/TD]
[TD]7447
[/TD]
[/TR]
[TR]
[TD]44444
[/TD]
[TD]wsdt111
[/TD]
[TD]8/12/12
[/TD]
[TD]Adam Jones
[/TD]
[TD]Houston
[/TD]
[TD]E-6410
[/TD]
[TD]7477
[/TD]
[/TR]
[TR]
[TD]77777
[/TD]
[TD]wsnb112
[/TD]
[TD]8/12/12
[/TD]
[TD]Ben Cade
[/TD]
[TD]Chicago
[/TD]
[TD]E-6420
[/TD]
[TD]7452
[/TD]
[/TR]
[TR]
[TD]77778
[/TD]
[TD]wsdt065
[/TD]
[TD]8/12/12
[/TD]
[TD]Lisa Wise
[/TD]
[TD]New York
[/TD]
[TD]E-6400
[/TD]
[TD]5255
[/TD]
[/TR]
</tbody>[/TABLE]

 

[dmt32]

Hello,

I am working on a Excel document, and I am trying to copy data over that have a value to sheet.

For Example,

I have 7 colums starting from B3 to H3, and what I am trying to do is copy the rows based on location to that sheet. Each sheet will be named by location so for example, Houston will have a sheet named Houston, and I want to copy all the rows to the Houston sheet, and so forth with the other locations. I know I can manually copy and paste them over, but is there away to do this just by entering the location on the main sheet page, and have it go to the desired location. I Hope this makes sense.

Thanks,

Ben

[TABLE="class: outer_border, width: 500"]
<TBODY>[TR]
[TD]Service Tag
[/TD]
[TD]Name
[/TD]
[TD]Date Received
[/TD]
[TD]Assigned to
[/TD]
[TD]Location
[/TD]
[TD]Model
[/TD]
[TD]Ticket
[/TD]
[/TR]
[TR]
[TD]12222
[/TD]
[TD]wsdt012
[/TD]
[TD]8/12/12
[/TD]
[TD]Bob Smith
[/TD]
[TD]Houston
[/TD]
[TD]E-6400
[/TD]
[TD]7447
[/TD]
[/TR]
[TR]
[TD]44444
[/TD]
[TD]wsdt111
[/TD]
[TD]8/12/12
[/TD]
[TD]Adam Jones
[/TD]
[TD]Houston
[/TD]
[TD]E-6410
[/TD]
[TD]7477
[/TD]
[/TR]
[TR]
[TD]77777
[/TD]
[TD]wsnb112
[/TD]
[TD]8/12/12
[/TD]
[TD]Ben Cade
[/TD]
[TD]Chicago
[/TD]
[TD]E-6420
[/TD]
[TD]7452
[/TD]
[/TR]
[TR]
[TD]77778
[/TD]
[TD]wsdt065
[/TD]
[TD]8/12/12
[/TD]
[TD]Lisa Wise
[/TD]
[TD]New York
[/TD]
[TD]E-6400
[/TD]
[TD]5255
[/TD]
[/TR]
</TBODY>[/TABLE]

not tested but this may do what you want. Place both procedures in standard module & adjust as required.

dave
Option Explicit
Sub Locations()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim Datarng As Range
Dim rowcount As Long
Dim location As Range
Set ws1 = Sheets("Sheet1") '<< your master sheet rename as required
Application.ScreenUpdating = False
With ws1
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Datarng = .Range("B3:H" & rowcount)
.Range("F3:F" & rowcount).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("J1"), _
Unique:=True
rowcount = .Cells(.Rows.Count, "J").End(xlUp).Row
'set Criteria
.Range("L1").Value = .Range("F3").Value

For Each location In .Range("J2:J" & rowcount)
'add the location to criteria
.Range("L2").Value = location.Value
'if location sheet exists
'update it
If SheetExists(location.Value) Then

Sheets(location.Value).Cells.Clear
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws1.Range("L1:L2"), _
CopyToRange:=Sheets(location.Value).Range("A1"), _
Unique:=False
Else
'add new sheet
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = location.Value
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws1.Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next

.Select

.Columns("J:L").Clear

End With
Application.ScreenUpdating = True
End Sub

Function SheetExists(wksName As String) As Boolean
On Error Resume Next
SheetExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[Benastros]

Sweet!!, this works like a charm!!! You made my week


Thanks,

Ben

 

[dmt32]

Sweet!!, this works like a charm!!! You made my week


Thanks,

Ben

Hi Ben,
glad I could help

Dave