Copy non blank cells from 1 sheet to multuiple sheets

[waxback]

Help, I have a register on sheet 1 (Master Sheet) containing in column B
Location which is selected from a list, column C Client Name, column D is
either blank or contains an X, my problem is i have 4 sheets one for each
Location, every week the Master sheet is updated and i need the cells
containing data to be copied into the relevant Location sheets.

example; South Peter
West Toby X
North Jenny
East Steve
West Donna X
North Jerry

I need Client in South to be copied over to Sheet South along with the X if
entered, and i need this in a way that there are no blank rows between the
clients on each sheet, hope i made the request clear if not i may be able to
show an example of what i need to do,

Thanks

 

[Leith Ross]

Help, I have a register on sheet 1 (Master Sheet) containing in column B
Location which is selected from a list, column C Client Name, column D is
either blank or contains an X, my problem is i have 4 sheets one for each
Location, every week the Master sheet is updated and i need the cells
containing data to be copied into the relevant Location sheets.

example; South Peter
West Toby X
North Jenny
East Steve
West Donna X
North Jerry

I need Client in South to be copied over to Sheet South along with the X if
entered, and i need this in a way that there are no blank rows between the
clients on each sheet, hope i made the request clear if not i may be able to
show an example of what i need to do,

Thanks

Hello waxback,

This macro will copy the client name and the "X" to the worksheet
whose name in column "B". The macro assumes the Master worksheet
("Sheet1") starts at row 2. The data is copied over to the other sheet
to columns "A" and "B". You can change these if you need to.

----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub CopyClients()

Dim LastEntry As Range
Dim LRCol As New Collection
Dim MasterWks As Worksheet
Dim Wks As Worksheet

Set MasterWks = Worksheets("Sheet1")

'Create a collection of the last row on each worksheet
For Each Wks In Worksheets
With Wks
Set LastEntry = .Cells.Find(What:="*", LookIn:=xlValues,
LookAt:=xlWhole, _
SearchDirection:=xlPrevious,
SearchOrder:=xlRows, _
MatchCase:=False)
If Not LastEntry Is Nothing Then
LRCol.Add LastEntry.Row, Wks.Name
Else
LRCol.Add 1, Wks.Name
End If
End With
Next Wks

'Loop through the clients
With MasterWks
For R = 2 To LRCol(.Name)
If .Cells(R, "D") = "X" Then
Set Wks = Worksheets(.Cells(R, "B"))
'Update the last row
NextRow = LRCol(Wks.Name) + 1
'Check if the row is beyond the end of the sheet
If NextRow > Wks.Rows.Count Then
MsgBox Wks.Name & " is full."
Exit Sub
End If
'Update the collection
LRCol.Remove (Wks.Name)
LRCol.Add NextRow, Wks.Name
'Copy the client to the correct worksheet
.Cells(R, "C").Resize(1, 2).Copy
Destination:=Wks.Cells(NextRow, "A")
End If
Next R
End With

End Sub

 

[waxback]

Hi Leith,

Thanks for the info, i have copy and pasted the macro into the module, but
get subscript out of range when i choose to debug it highlights Set MasterWks
= Worksheets("Sheet1") yellow, any idea what i'm doing wrong.

Regards
Waxback

 

[ryguy7272]

I think this will do what you want:
Sub newone()
Dim RngColD As Range
Dim i As Range
Dim Dest As Range
Sheets("Sheet1").Select
Set RngColD = Range("D1", Range("D" & Rows.count).End(xlUp))
With Sheets("Sheet2")
Set Dest = .Range("A1")
End With
For Each i In RngColD
If i.Value = "x" Then
i.EntireRow.Copy Dest
Set Dest = Dest.Offset(1)
End If
Next i
End Sub

Change the sheet names to suit your needs.

Regards,
Ryan---

 

[waxback]

Cheers Ryan,

Excellent stuff, managed to get it working with your code, is there a way
for the copy process not to include the formatting from sheet1 ?

Truly appreciated

Regards
Adrian