Copy Non-Consecutive Rows and Paste in a Seperate Worksheet

[elf27]

I have two worksheets I'm working on.
The first has a long list of items characterized in by one of four
identifiers (Adam, Bob, Charlie, David). So it would be something like this:

Adam Task 1 Due date X
Bob Task 34 Due date Y
Adam Task 2 Due date Z
Charlie Task 34 Due date Y
David Task 34 Due date Y
....

I want to make it so all of the rows for Adam (an none of the other rows)
are copied and pasted on to a separate worksheet. Then I will do the same for
Bob, Charlie, and David.

To make it even more complex, I do not want to past the entire contents of
each row, just certain columns. Here, let's say columns 1 and 2. So, the
resulting page for Adam would look like:
Adam Task 1
Adam Task 2

I've been wrestling with this for hours and can't get anywhere. Help! Thank
you very much!

 

[Bob Phillips]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long
Dim sh As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 1 To LastRow

If .Cells(i, "A").Value <> sh Then

sh = .Cells(i, "A").Value
On Error Resume Next
If Not Worksheets(sh).Name = sh Then Worksheets.Add.Name =
sh
On Error GoTo 0
If Worksheets(sh).Range("A1").Value = "" Then

NextRow = 1
Else

NextRow = Worksheets(sh).Range("A" &
..Rows.Count).End(xlUp).Row + 1
End If

.Cells(i, "A").Resize(, 2).Copy
Worksheets(sh).Cells(NextRow, "A")
End If
Next i
End With
End Sub

 

[elf27]

Bob,
Thanks for your reply.
I'm getting a compiling error though because of an Else without an If. In
this portion of the code:

If Worksheets(sh).Range("A1").Value = "" Then NextRow = 1
Else NextRow = Worksheets(sh).Range("A" &
..Rows.Count).End(xlUp).Row + 1


I realize there's an if there, but Excel doesn't.


Thanks again.

 

[Bob Phillips]

You seem to have rolled individual lines in my code into 1. The NG also
wrapped lines, see if this is any better

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long
Dim sh As String

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 1 To LastRow

If .Cells(i, "A").Value <> sh Then

sh = .Cells(i, "A").Value
On Error Resume Next
If Not Worksheets(sh).Name = sh Then _
Worksheets.Add.Name = sh
On Error GoTo 0
If Worksheets(sh).Range("A1").Value = "" Then

NextRow = 1
Else

NextRow = Worksheets(sh).Range("A" & _
.Rows.Count).End(xlUp).Row + 1
End If

.Cells(i, "A").Resize(, 2).Copy _
Worksheets(sh).Cells(NextRow, "A")
End If
Next i
End With
End Sub

 

[elf27]

Still not working.
Getting an "error 9. Subscript out of range" on the line:
If Worksheets(sh).Range("A1").Value = "" Then

For some reason, it's creating a new sheet but not naming it (it remains
'Sheet 1') while sh has the file name as the value. That's why when it tries
to go to the worksheet called sh it's out of range.

 

[elf27]

Actually, previous post was wrong. I got it to work, but the problem is that
it created 130 sheets and then errored out.
Each sheet only had one line of information

 

[Dave Peterson]

Do you have empty cells in column A?

How about strings that contain invalid characters in those cells (maybe dates
using the slash character)?

Add a line to help debug the program:

If .Cells(i, "A").Value <> sh Then
msgbox i & vblf & .cells(i,"A").value
sh = .Cells(i, "A").Value

I bet Bob's routine would work fine with the test data you shared. But the fix
may depend on what's in those cells that's causing the error.

 

[keiji kounoike]

How about adding some line and change codes a little like below.

keiji

Actually, previous post was wrong. I got it to work, but the problem is that
it created 130 sheets and then errored out.
Each sheet only had one line of information

add the code below

Dim Acsh as Worksheet

set Acsh=ActiveSheet
Change the line below

to

With Acsh

 

[elf27]

First, when I referred to a previous post being wrong, I meant mine, not
Dave's (see above). Dave was right that the problem was an empty value in a
cell. Sorry, Dave.

The below code works with the data I'm using. Unfortunately, I've got some
formulas in some of the cells and a slew of conditional formatting that I
need to keep. When it pastes in to the new worksheet, it pastes the formulas.
Any tips on pasting values? The commented-out pastevalues lines cause errors.

Public Sub ProcessData()
Const AEName As String = "B" '<=== change to suit
Dim i As Long
Dim T As Long
Dim LastRow As Long
Dim NextRow As Long
Dim sh As String

With Sheet1
T = .Cells(.Rows.Count, "A").End(xlUp).Row
i = 8
Do Until LastRow <> 0
If .Cells(i + 2, "A").Value = "" Then
LastRow = i + 1
Else: LastRow = 0
i = i + 1
End If
Loop
End With

With Sheet1
For i = 8 To LastRow

If .Cells(i, AEName).Value <> sh Then
sh = .Cells(i, AEName).Value
On Error Resume Next
If Not Worksheets(sh).Name = sh Then _
Worksheets.Add.Name = sh
On Error GoTo 0
If Worksheets(sh).Range("A1").Value = "" Then
NextRow = 1
Else
NextRow = Worksheets(sh).Range("A" & _
.Rows.Count).End(xlUp).Row + 1
End If

.Cells(i, "A").Resize(, 2).Copy _
Worksheets(sh).Cells(NextRow, "A")
' .PasteSpecial xlValues
' .PasteSpecial xlFormats

End If


Next i
End With

 

[keiji kounoike]

I don't know why you use Do loop for looking for the first non blank cell.
I might be wrong, but just ignoring blank cells is enough.

About pasting values, i think it's just a matter of using wrong syntax.
I've tried to revise your code. but not sure this would work in your case.

Public Sub ProcessData()
Const AEName As String = "B" '<=== change to suit
Dim i As Long
Dim T As Long
Dim LastRow As Long
Dim NextRow As Long
Dim sh As String

With Sheet1

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 8 To LastRow
sh = .Cells(i, AEName).Value
If sh <> "" Then
On Error Resume Next
If Not Worksheets(sh).Name = sh Then _
Worksheets.Add.Name = sh
On Error GoTo 0
If Worksheets(sh).Range("A1").Value = "" Then
NextRow = 1
Else
NextRow = Worksheets(sh).Range("A" & _
.Rows.Count).End(xlUp).Row + 1
End If

.Cells(i, "A").Resize(, 2).Copy
Worksheets(sh).Cells(NextRow, "A").PasteSpecial xlValues
Worksheets(sh).Cells(NextRow, "A").PasteSpecial xlFormats
End If
Next i
End With

End Sub

keiji

 

[elf27]

Keiji

I use the loop because the last cell according to Excel is different than
the last one in the list I want to use.

The addition of:
..Cells(i, "A").Resize(, 2).Copy
Worksheets(sh).Cells(NextRow, "A").PasteSpecial xlValues
Worksheets(sh).Cells(NextRow, "A").PasteSpecial xlFormats

Slowed down the macro significantly. Not sure why.
I also think it only pasted values, the formats did not transfer for some
reason.

 

[keiji kounoike]

Hi elf27

Adding the line below before With Sheet1 might improve the speed.

Application.ScreenUpdating = False

In my environment, it transfers both values and formats, so I have no
idea about not working in your side.

if showing your tested code, someone else could give you the reason.

Keiji