VBA to Copy and paste

Microsoft Windows xp inside out, second...
January 1, 2010 at 20:39:29
Specs: Windows XP, pentium 4 3.00Ghz. 1gb ram
How to write VBA(Macro) to copy rows containing "one" in Col.K of sheet1 then paste it to sheet2 beginning row 15, and rows containing "two" in col.K of sheet1 to sheet2 beginning row 75?


For your information the rows containing "one" in col. k of sheet1 in my worksheet is always less than 50 rows.


See More: VBA to Copy and paste

Report •

#1
January 2, 2010 at 06:00:19
Hi,

Try this:

Option Explicit

Public Sub OneTwo()
Dim rngSource As Range
Dim rngCell As Range
Dim rngOnes As Range
Dim rngTwos As Range
Dim intOnes As Integer
Dim intTwos As Integer

On Error GoTo ErrHnd

'Set destination row origins
Set rngOnes = Worksheets("Sheet2").Range("A15")
Set rngTwos = Worksheets("Sheet2").Range("A75")
'Set destination row counters
intOnes = 0
intTwos = 0

With Worksheets("Sheet1")
    'In col K look in rows 1 to last row used
    Set rngSource = .Range("K1", .Range("K65534").End(xlUp))
    'loop through cells in column K
    For Each rngCell In rngSource
        If rngCell.Text = "one" Then
            'copy row containing 'one' to row on sheet2 starting at row 15
            rngCell.EntireRow.Copy Destination:=rngOnes.Offset(intOnes, 0)
            'increment row ones counters
            intOnes = intOnes + 1
        ElseIf rngCell.Text = "two" Then
            'copy row containing 'two' to row on sheet2 starting at row 75
            rngCell.EntireRow.Copy Destination:=rngTwos.Offset(intTwos, 0)
            'increment row Twos counters
            intTwos = intTwos + 1
        End If
    Next rngCell
End With
Exit Sub

'error handler
ErrHnd:
Err.Clear
End Sub

Paste the code into a standard Module in your Workbook. Either run it using f5 with your cursor in the code in the VB Window, or if you are going to use it regularly, link the code to a toolbar button.

Note that the code only copies rows that contain all lower case words 'one' or 'two'. If you have upper case as well, then the code will need modifying.

Regards


Report •

#2
January 2, 2010 at 22:06:35
Thanks Humar. code works exactly as i ought it to be. If you don't mind, I would like to put another line for you, that is:

How can i do this for ranges. Say, B1:100 and C1:G100 of sheet1 to B1:100 and F1:J100 of sheet2 having one and two in col.K of sheet1 as above Original Post?


Report •

#3
January 3, 2010 at 05:05:29
Hi,

Just to be clear about what you want:

If cell K3 on Sheet1 contains "one" and it is the first cell in column K to contain "one"
... instead of the whole of row 3 being copied to sheet 2 row 15,
... you want Sheet1 Cell B3 copied to Sheet2 Cell B15
... and Sheet1 Cells C3 to G3 copied to Sheet2 Cells F15 to J15.

If the first cell in column K containing "two" was cell K4,
... you want Sheet1 cell B4 copied to Sheet2 Cell B75
... and Sheet1 Cells C4 to G4 copied to Sheet2 Cells F75 to J75.

The cells containing "one" or "two" would not be copied

Regards


Report •

Related Solutions

#4
January 3, 2010 at 19:48:39
Yes exactly.

Report •

#5
January 3, 2010 at 20:48:37
Hi,

I am away tomorrow, but I will work on it for you when I return.

Regards

Humar


Report •

#6
January 4, 2010 at 01:02:46
Ok waiting.

Report •

#7
January 4, 2010 at 10:20:22
Hi,

Managed to get to this earlier than expected.

Let me know if this does what you were looking for:

Public Sub OneTwo()
Dim rngSource As Range
Dim rngCell As Range
Dim rngOnes As Range
Dim rngTwos As Range
Dim intOnes As Integer
Dim intTwos As Integer

On Error GoTo ErrHnd

'Set destination row origins
Set rngOnes = Worksheets("Sheet2").Range("A15")
Set rngTwos = Worksheets("Sheet2").Range("A75")
'Set destination row counters
intOnes = 0
intTwos = 0

With Worksheets("Sheet1")
    'In col K look in rows 1 to last row used
    Set rngSource = .Range("K1", .Range("K65534").End(xlUp))
    'loop through cells in column K
    For Each rngCell In rngSource
        If rngCell.Text = "one" Then
            'copy cells in row containing 'one' to sheet2 starting at row 15
            'copy column B to column B
            rngCell.Offset(0, -9).Copy Destination:=rngOnes.Offset(intOnes, 1)
            'copy columns C to G to columns F to J
            rngCell.Offset(0, -8).Resize(1, 6).Copy Destination:=rngOnes.Offset(intOnes, 5)
            'increment row ones counters
            intOnes = intOnes + 1
        ElseIf rngCell.Text = "two" Then
            'copy cells in row containing 'two' to sheet2 starting at row 75
            'copy column B to column B
            rngCell.Offset(0, -9).Copy Destination:=rngTwos.Offset(intTwos, 1)
            'copy columns C to G to columns F to J
            rngCell.Offset(0, -8).Resize(1, 6).Copy Destination:=rngTwos.Offset(intTwos, 5)
            'increment row Twos counters
            intTwos = intTwos + 1
        End If
    Next rngCell
End With

Exit Sub
'error handler
ErrHnd:
Err.Clear
End Sub

Regards


Report •

#8
January 4, 2010 at 22:18:04
Yes thats what i need. Humar, you are excellent excel expert
and master. This office forum is nice to visit because of you and
DerbyDad03. Hope computing.net will be glorified in the days to
come through people like you.

But having said that, How to make the code(Response No. 7's)
to paste values only?

Have a nice day ahead. Thanks again Humar.


Report •

#9
January 5, 2010 at 05:39:22
Hi,

The all in one Copy with Destination:=
has to be replaced with two lines
Copy and a separate PasteSpecial.

Here is the first Copy/destination replaced with two lines:

            'copy column B to column B
            rngCell.Offset(0, -9).Copy
            rngOnes.Offset(intOnes, 1).PasteSpecial (xlPasteValues)

Repeat the process for the other three copy/destination lines.

You will see that the address calculations are the same as before.

To see other PasteSpecial options, when you have created the new PasteSpecial line in the VBA code window, put the cursor between the opening bracket and the x in (xlPasteValues)
Now backspace to delete the bracket, re-type the (
and a list of paste special options will appear.

I have just noticed that the resize for the second copy is one cell larger than it should be. Here is the corrected code, using the PasteSpecial:

            'copy columns C to G to columns F to J
            rngCell.Offset(0, -8).Resize(1, 5).Copy
            rngOnes.Offset(intOnes, 5).PasteSpecial (xlPasteValues)

You will need to correct the Resize in the 'twos' section as well.

Regards and thank you for your kind feedback.


Report •

#10
January 5, 2010 at 22:00:07
Many many thanks for your excellent code.

Report •

Ask Question