Copyit Macro

[Kendra]

Hey,

I have successfully used this macro to take information from one worksheet
to another, however I need to be able to do this with multiple in the same
workbook.

In one workbook I have four master worksheets and in each master worksheet
there are names in column A which have corrosponding worksheets. I need to
have the row connected to the name in the masters copied into each
corrosponding worksheet and these names may be changed throughout the day
weekly in the master sheets.

This is the formula for the macro I used to do this with one name:

Sub copyit()
Dim MyRange, MyRange1 As Range
Sheets("LIA").Select
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("LIA").Range("A1:A400" & lastrow)
For Each c In MyRange
If c.Value = "ST" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Copy
End If

Sheets("ST").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False

End Sub


'LIA' is one of the master sheets and 'ST' is the name I had it copy from
column A into the worksheet titled 'ST', I have about 13 of these names just
in the master LIA and each have their own worksheet and then 3 other master
sheets with their own names and corrosponding worksheets all in one workbook.

Can I make changes to the existing macro formula to allow for this
complicated need or do I have to make 20 different macros?

If someone could be a genius and help me sort this out I would be in awe.

 

[Sheeloo]

Try
'See comments like this line
'This assumes that the sheet with each name already exists
'otherwise you wil have to add code to check for existence and then add it
'

Sub copyit()

Dim shName As String
Dim MyRange As Range
'Dim shCount As Integer
'shCount = Worksheets.Count
'Dim lastRow(shCount) As Long
'For i = 1 To shCount
'lastRow(i) = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
'Next
Dim srcSheet(4) As String
'Change the names to the four sheets you want to copy from
srcSheet(1) = "LIA"
srcSheet(2) = "LIA"
srcSheet(3) = "LIA"
srcSheet(4) = "LIA"

'Comment the next five lines if you do not want to clear the name sheets
For Each ws In Worksheets
If (ws.Name <> srcSheet(1) And ws.Name <> srcSheet(2) And ws.Name <>
srcSheet(3) And ws.Name <> srcSheet(4)) Then
Sheets(ws.Name).UsedRange.ClearContents
End If
Next

For i = 1 To 4
Set MyRange = Sheets(srcSheet(i)).Range("A1:A" &
Sheets(srcSheet(i)).Cells(Rows.Count, "A").End(xlUp).Row)
For Each c In MyRange
shName = c.Value
If shName <> "" Then
c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(Sheets(shName).Cells(Rows.Count,
"A").End(xlUp).Row + 1, 1)
End If
Next
Next
End Sub

 

[Kendra]

Thank you, and sorry about the 2nd post.

I do have a couple questions to clarify the code you provided.

Other than: (I've named these sheets as seen)
srcSheet(1) = "LIA"
srcSheet(2) = "MCP"
srcSheet(3) = "SLCP"
srcSheet(4) = "CCP"

Where do I indicate the name for the macro to find and copy the
corrosponding row into the matching worksheet.

Ex:
I need it to find all rows with 'ST', 'SE', and 'BW' in the 'LIA' worksheet
and sort them into the worksheets named as such. Also I need it to paste
starting at 'A6'


Thanks in advance for your help.

 

[Sheeloo]

Try this
(I have sacrificed efficiency for clarity)..

Sub copyit()

Dim i, j As Integer
j = 1
Dim shName As String
Dim myRange As Range
Dim sh As Worksheet

Dim destRow(3) As Integer
destRow(1) = 5
destRow(2) = 5
destRow(3) = 5

Dim srcSheet(4) As String
srcSheet(1) = "LIA"
srcSheet(2) = "MCP"
srcSheet(3) = "SLCP"
srcSheet(4) = "CCP"

'Comment the next five lines if you do not want to clear the name sheets
For Each ws In Worksheets
If (ws.name <> srcSheet(1) And ws.name <> srcSheet(2) And ws.name <>
srcSheet(3) And ws.name <> srcSheet(4)) Then
Sheets(ws.name).UsedRange.ClearContents
End If
Next

For i = 1 To 4
Set myRange = Sheets(srcSheet(i)).Range("A1:A" &
Sheets(srcSheet(i)).Cells(Rows.Count, "A").End(xlUp).Row)

For Each c In myRange
shName = c.Value

'ST', 'SE', and 'BW'
If (shName = "ST" Or shName = "SE" Or shName = "BW") Then

If shName = "ST" Then
j = 1
End If

If shName = "SE" Then
j = 2
End If

If shName = "BW" Then
j = 3
End If

destRow(j) = destRow(j) + 1

c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(destRow(j), 1)

End If

Next c
Next i
End Sub

 

[Kendra]

I keep getting a 'Compile Error: Syntax Error' pop up.

I feel like a complete idiot but I just can not get this to work and these
lines:

If (ws.name <> srcSheet(1) And ws.name <> srcSheet(2) And ws.name <>

Set myRange = Sheets(srcSheet(i)).Range("A1:A" &

Sheets(srcSheet(i)).Cells(Rows.Count, "A").End(xlUp).Row)

Are red in the module.

Sorry in advance and thank you.

 

[Sheeloo]

Don't be harsh on yourself...

If (ws.name <> srcSheet(1) And ws.name <> srcSheet(2) And ws.name <>
srcSheet(3) And ws.name <> srcSheet(4)) Then
The above (from IF to THEN) should be on one line

Similary the whole of (from SET to .Row))
Set myRange = Sheets(srcSheet(i)).Range("A1:A" &
Sheets(srcSheet(i)).Cells(Rows.Count, "A").End(xlUp).Row)
should be on one line

These should also be on one line

 

[Kendra]

It worked!!!

Thank you so much! I had the lines with an additional space I beleive but
when I changed it to be a continuous line it worked like magic!

One more question:

I just need to repeat, or copy paste, these lines with different names to
add more correct?:

If shName = "ST" Then
j = 1
End If

Again, thank you so much for your help. It's much appreciated.

 

[Kendra]

I got it working for all of the sheets.

However there is one minor problem, when it pastes the row it wipes out all
the frames and colum titles and other formulas I have on the sheets.

Is there any way to get it to only paste in a specified range of rows, i.e.
A6 thru A34?

It already pastes starting at A6 but even text above that row gets wiped out.

Do you now what that's from or a simple fix?

Thanks again for all of your help.

 

[Sheeloo]

Great you could make it work..

You did not notice my comment in the code
Delete this part in the code and existing heading won't be deleted...

It will stop before 34 if there is not enough data. Do you want it to stop
even if there is more data?

 

[Kendra]

I did see the msg I just didn't quite understand it, but now it makes total
sense.

Thanks for that, it handled it.

I have formulas below line 34 that calculated what is pasted above so I just
want to avoid having those wiped out. Though I don't believe that will occur.
I just want to make sure it's protected.

You've been a huge help and a life saver, thanks for your time and
brilliance on this!

 

[Sheeloo]

Glad this worked for you...

If you want to stay above line 34 then use this
If desRow(j) < 35 then
c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(destRow(j), 1)
end if

instead of
c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(destRow(j), 1)

but then you will miss on names which may be there...

Use this as the starting point to learn VBA, it is fun...

 

[Kendra]

Awesome! You've been a huge help! And I am enjoying learning this.

.... one last Q, is there a way I can have it only copy and paste the row up
to a specific column, such as M or L?

And if so, can I customize it so that it varies as to which column it copy
and pastes per master sheet; LIA, MCP, SLCP, & CCP?

 

[Sheeloo]

See the code below...you can adapt it to your need...

It finds the lastRow (in first col) and lastCol (in first row) on the
current sheet (ActiveSheet), then selects row 1 upto the last col and pastes
it below the last row

Sub test()
Dim lastRow, lastCol As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
ActiveSheet.Range(Cells(1, 1), Cells(1, lastRow)).Copy _
Destination:=.Cells(lastRow + 1, 1)
End With
End Sub

 

[Kendra]

Do I need to insert that into the macro at a specific place?

I'm not sure I understand how to edit it for my needs.

 

[Sheeloo]

You have to use the idea in the macro to get the last Col for each sheet...

You need to get lastCol for each sheet
Then copy each row upto lastCol

If you are unable to make it work then
Paste the code you have now, and I will try to update it.

 

[Kendra]

It looks like it only does it for the sheet I may be looking at at the time I
run it.

I need it to do it for all of them when is copy and pastes to just copy and
past up to a certain column so that it doesn't wipe out the formulas I have
in columns N, O, P, and so on.

Similar to the idea that I didn't want it to paste anything beyond row 34.

Anyway, I'm not sure how to adjust it to these preferances. Here's the macro
I currently have running that works like a charm except for that minor
detail, it's pretty long:


Sub copyit()

Dim i, j As Integer
j = 1
Dim shName As String
Dim myRange As Range
Dim sh As Worksheet

Dim destRow(22) As Integer
destRow(1) = 3
destRow(2) = 3
destRow(3) = 3
destRow(4) = 3
destRow(5) = 3
destRow(6) = 3
destRow(7) = 3
destRow(8) = 3
destRow(9) = 3
destRow(10) = 3
destRow(11) = 3
destRow(12) = 3
destRow(13) = 3
destRow(14) = 3
destRow(15) = 3
destRow(16) = 3
destRow(17) = 3
destRow(18) = 3
destRow(19) = 3
destRow(20) = 3
destRow(21) = 3
destRow(22) = 3

Dim srcSheet(4) As String
srcSheet(1) = "LIA"
srcSheet(2) = "MCP"
srcSheet(3) = "SLCP"
srcSheet(4) = "CCP"

For i = 1 To 4
Set myRange = Sheets(srcSheet(i)).Range("A1:A" &
Sheets(srcSheet(i)).Cells(Rows.Count, "A").End(xlUp).Row)

For Each c In myRange
shName = c.Value

'ST', 'SE', and 'BW'
If (shName = "ST" Or shName = "SE" Or shName = "BW" Or shName = "MP" Or
shName = "GM" Or shName = "SN" Or shName = "BUD" Or shName = "DS" Or shName =
"JW" Or shName = "JW" Or shName = "DH" Or shName = "JC" Or shName = "JD" Or
shName = "GF" Or shName = "JM" Or shName = "SB" Or shName = "CG" Or shName =
"ED" Or shName = "JBW" Or shName = "MH-SLCP" Or shName = "JLB" Or shName =
"CR" Or shName = "MH-LIA") Then

If shName = "ST" Then
j = 1
End If

If shName = "SE" Then
j = 2
End If

If shName = "BW" Then
j = 3
End If

If shName = "MP" Then
j = 4
End If

If shName = "GM" Then
j = 5
End If

If shName = "SN" Then
j = 6
End If

If shName = "BUD" Then
j = 7
End If

If shName = "DS" Then
j = 8
End If

If shName = "JW" Then
j = 9
End If

If shName = "DH" Then
j = 10
End If

If shName = "JC" Then
j = 11
End If

If shName = "JD" Then
j = 12
End If

If shName = "GF" Then
j = 13
End If

If shName = "JM" Then
j = 14
End If

If shName = "SB" Then
j = 15
End If

If shName = "CG" Then
j = 16
End If

If shName = "ED" Then
j = 17
End If

If shName = "JBW" Then
j = 18
End If

If shName = "MH-SLCP" Then
j = 19
End If

If shName = "JLB" Then
j = 20
End If

If shName = "CR" Then
j = 21
End If

If shName = "MH-LIA" Then
j = 22
End If

destRow(j) = destRow(j) + 1

c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(destRow(j), 1)

End If

Next c
Next i
End Sub

 

[Kendra]

Perhaps there is a simple edit to my existing macro that only copies the row
from the main sheets up to column 'L'.

I can't quite figure out how to edit it so that it specifies that though.
I've been futsing with it and I just get errors.

It appears to me that the code just at the end of the macro specifies what
to copy:

c.EntireRow.Copy _
Destination:=Sheets(shName).Cells(destRow(j), 1)

Do you know how to adjust it so it only copies the row to a specified point?

I think that would handle it.