Need help with Transpose paste special

[Paul]

In Sheet "Printers" I have a column of over 15K rows.
Every 8 rows the data in Col A repeats.
I want to copy the corresponding cells in column B
and Transpose them into Sheet1 so the data in B aligns under the
headings
from col A.
So I am using a Search and Find to pick my next batch of rows to copy.
When I do the paste, my data is screwed up.
Can anyone see where I have gone wrong.

I am self taught and not too good on VB.

Thanks in advance.

Paul

I have the following code:
Sub PstTranspose()
'

Sheets("Printers").Activate
Cells.Find(What:="Text Description", After:=ActiveCell,
LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 1).Select
Range(ActiveCell, ActiveCell.Offset(7, 0)).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.End(xlUp).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
ActiveSheet.Paste


End Sub

 

[JE McGimpsey]

If I understand you correctly, here's one way:

Public Sub PstTranspose()
Dim rDest As Range
Dim rFound As Range
With Sheets("Sheet1")
Set rDest = .Range("A1").End(xlUp).Offset(1, 0).Resize(2, 8)
End With
With Sheets("Printers").Cells
Set rFound = .Find( _
What:="Text Description", _
After:=.Cells(.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns, _
MatchCase:=False)
If Not rFound Is Nothing Then _
rDest.Value = Application.Transpose( _
rFound.Offset(1, 0).Resize(8, 2).Value)
End With
End Sub

Note that you almost never need to select a range. Using the range
object directly makes your code smaller, faster, and IMO easier to
maintain.

 

[Paul]

Thanks for your reply JE.
However I don't get the result I need.
This code is selecting the first 8 cells of column A, and pasting into
Sheets1 into Row 1.
And it's not looping.

Here is a sample of my data:
A B C
1 Queue ALBERT Library
2 Remote printer queues ALBERT blank
3 Internet address 10.18.52.152 "
4 Destination type *OTHER "
5 Manufacturer type and model *WSCST "
6 Workstation customizing object HP4100TN
7 Destination options *NONE
8 Text description TESTER DELETE
9 Queue ALB4224 Library
10 Remote printer queues blank
11 Internet address blank
12 Destination type blank
13 Manufacturer type and model blank
14 Workstation customizing object blank
15 Destination options blank
16 Text description Default output queue for printer ALB

AS you can see column A repeats every 8 rows, for some 1500 times,
and column B has some
blank or empty cells, but not each and every case.

So Column A is my headings in Sheet1 and Column B is my data.

Appreciate your time on this.

Cheers Paul

 

[JE McGimpsey]

I'm having trouble envisioning what you want your output to be...

 

[Paul]

It's supposed to look like this: (Sorry if this is a bit difficult to
Read)
Col A B C D
R1 'Queue' 'Remote printer queues' 'Internet
address' 'Destinationtype'

E F
G
'Manufacturer type and model' 'Workstation customizing
object' 'Destination
G H
options' 'Text description'
A B C D E F
R2 'ALBERT Library'
'ALBERT' '10.18.52.152' '*OTHER''*WSCST''HP4100TN'
G H
'*NONE' 'TESTER DELETE'
A B C D E F
G
R3 'ALB4224 Library' 'Blank' 'Blank' 'Blank' 'Blank' 'Blank'
'Blank
H
'Default output queue for printer ALB'

Columns in A B C etc up to H
Rows 1, 2 3 Where Row 1 has the column headings.
Column headings come from Cells A1 to A8 in my 'Printers' Worksheet.


Rows A1 to A8, repeat down for some 1500 times, and the adjacent
column B has the corresponding data.

So I want to Transpose Col B data, every 8 rows, into Sheet1, under
the corresponding column heading.

Sorry if this is not to clear.

I'm using the find, to located the next 8th row of text, because I
don't know how to make the code count down 8 rows and copy/paste
transpose, and then count next 8 rows, copy the 8 and paste transpose
again, repeating to the end.

Again thanks for your time on this.
Greatly appreciated.

I have modified your code slightly, but I cannot get it to loop.

Public Sub PstTranspose()
Dim rDest As Range
Dim rFound As Range
With Sheets("Sheet1")
Set rDest = .Range("A1").End(xlDown).Offset(1,
0).Resize(1, 8)
End With
With Sheets("Printers").Cells
Set rFound = .Find( _
What:="Text Description", _
After:=ActiveCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns, _
MatchCase:=False)
If Not rFound Is Nothing Then _
rDest.Value = Application.Transpose( _
rFound.Offset(1, 0).Resize(8, 2).Value)
End With
Sheets("printers").Activate
Cells.FindNext(After:=ActiveCell).Activate
End Sub