Macro to copy and paste in another Worksheet

Hi, this is my 1st post here and I hope You can help me.
I'm not a programmer so I confess I did the following macro copying and pasting here and there...
I would like to ask for Your support as I need to add a new feature to this macro but I don't know how to do it and I hope You do!
The following code takes an excel file and splits its lines into 2 blank worksheets depending on a certain caracter inside a certain cell.
It works fine, but I need to add an extra feature.
I would like that:
1) When done, in the worksheet "a" a new blank column is created after column "B".
2) The "A" column inside worksheet "b" is copied into the empy column created at step 1.
Can anyone help me to modify this line so that they do this operation too?

[VBA]Public Sub CopyRows()
Sheets("Sheet1").Select
' Find the last row of data
FinalRow = Range("A65536").End(xlUp).Row
' Loop through each row
For x = 14 To FinalRow
' Decide if to copy based on column H
ThisValue = Range("K" & x).Value
If ThisValue = "R" Then
Range("A" & x & ":S" & x).Copy
Sheets("a").Select
NextRow = Range("A65536").End(xlUp).Row + 1
Range("A" & NextRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
ElseIf ThisValue = "" Then
Range("A" & x & ":S" & x).Copy
Sheets("b").Select
NextRow = Range("A65536").End(xlUp).Row + 1
Range("A" & NextRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next x
End Sub[/VBA]

Thanks in advance for Your attention.

wellcome to the Forum.
try this. untested. so work with a copy first.



[vba]
Public Sub CopyRows()

Dim wsBase As Worksheet, wsA As Worksheet, wsB As Worksheet
Dim Calc As Long, FinalRow As Long, x As Long

Set wsBase = Worksheets("Sheet1")
Set wsA = Worksheets("a")
Set wsB = Worksheets("b")

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
Calc = .Calculation
.Calculation = xlCalculationManual
End With

With wsBase
FinalRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 14 To FinalRow
If .Range("K" & x).Value = "R" Then
.Range("A" & x & ":S" & x).Copy wsA.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ElseIf .Range("K" & x).Value = "" Then
.Range("A" & x & ":S" & x).Copy wsB.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next x
End With

wsA.Columns("C").EntireColumn.Insert
wsB.Range("A1:A" & wsB.Cells(Rows.Count, "A").End(xlUp).Row).Copy wsA.Range("C1")

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = Calc
End With

End Sub
[/vba]

It works perfectly, many thanks, I really appreciated Your time!:thumb

you're wellcome.

pls mark the thread "solved" from Thread Tools above the first post in his page.

Quote:

---

Originally Posted by mancubus

you're wellcome.

pls mark the thread "solved" from Thread Tools above the first post in his page.

---

Sorry but I can't see what You are referring to....
If I click on "Thread tool" it brings down the page, but I can't mark anything (print/search/email)

This happens on me as well if my browser is Chrome :)

Quote:

---

Originally Posted by alccad

Sorry but I can't see what You are referring to....
If I click on "Thread tool" it brings down the page, but I can't mark anything (print/search/email)

---

internet explorer will do it.