Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

Did you modify my code to cover entire range of cells where you have data.

"WestWingFan" wrote:

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

I did not, because the given range was sufficient. I just tried modifying it
and it still fails after three cases.

"Joel" wrote:

Did you modify my code to cover entire range of cells where you have data.

"WestWingFan" wrote:

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

What data is in the cell? Is there anything special about the cell like
being a merged cell?

"WestWingFan" wrote:

I did not, because the given range was sufficient. I just tried modifying it
and it still fails after three cases.

"Joel" wrote:

Did you modify my code to cover entire range of cells where you have data.

"WestWingFan" wrote:

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

The copied cell (range of cells) has text. Not merged with anything.

FYI - To test, I tried the macro on another workbook. The macro (as written)
works on some worksheets for 4 loops, but not for others.

"Joel" wrote:

What data is in the cell? Is there anything special about the cell like
being a merged cell?

"WestWingFan" wrote:

I did not, because the given range was sufficient. I just tried modifying it
and it still fails after three cases.

"Joel" wrote:

Did you modify my code to cover entire range of cells where you have data.

"WestWingFan" wrote:

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12

If you want to send me a file I will look at it. Can't find the problem
without actual data.

joel dot warburg at itt dot com


"WestWingFan" wrote:

The copied cell (range of cells) has text. Not merged with anything.

FYI - To test, I tried the macro on another workbook. The macro (as written)
works on some worksheets for 4 loops, but not for others.

"Joel" wrote:

What data is in the cell? Is there anything special about the cell like
being a merged cell?

"WestWingFan" wrote:

I did not, because the given range was sufficient. I just tried modifying it
and it still fails after three cases.

"Joel" wrote:

Did you modify my code to cover entire range of cells where you have data.

"WestWingFan" wrote:

Joel,

I tried your code before the loop, which fixed it once, (up to 3 times
now!), and in the loop before the first copy/paste, which also only allowed
me to copy 3 times, but fails with the same error on the 4th. So, something
is still batty, but I'm baffled as to what.

"Joel" wrote:

I don't like blank cells because not all empty cells are blank. I usually
use "" (null string) to avoid this problem.

You can try clearing the cells that have problems

For Each cell In ActiveSheet.Range("A1:Z2000")

If cell.Value = "" Then
cell.ClearContents
End If
Next cell

"WestWingFan" wrote:

Joel,

Thank you for responding. To the best of my ability to determine there is a
blank cell in that column, but the code isn't "seeing" the same thing I am.
It fails on some data/worksheets, but not others. I don't know what to look
for to differentiate the two types of worksheets - ones it works on vs. fails
on. Any ideas?

"Joel" wrote:

It is always a good idea to check if code return a value beofre preceeding

Set eCell = _
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
if not eCell is nothing then
eCell.Select
ActiveSheet.Paste
else
msgbox "Cannot Find blnak cells"
end if


"WestWingFan" wrote:

Hello Gurus!

Thanks in advance for your help. I'm trying to reformat a spreadsheet so the
data will be easily entered into a database. The basics are taking data in
rows, transposing it to columns like so:

Row1
Row2
Row3
Row4

Column1 Column2 Column3
Row1 Row2 Row3
Row1 Row2 Row4

When I have a sheet with 4 rows, the code gives me an "cannot find cell"
error when looking for the next blank cell in column1. Any Ideas? I'll copy
the code in and indicate the line below.


Sub DeliverableReformat()
'Macro to reformat
Dim Looptimes As Integer
Dim BookObject As Range


'Select All, Copy, Paste Special - transpose
Range("A1:AZ9").Select
Selection.Copy
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

'delete original data
Rows("1:9").Select
Selection.Delete Shift:=xlUp

[A1].Select
'count columns (to determine how many times to loop)
Looptimes = LastColumn - 1
'run to here and then check It's highliting AD1-AD6?

'insert title row
[M1].Value = "HCPS Benchmark Code"
[N1].Value = "Publisher"
[O1].Value = "Imprint"
[P1].Value = "Title"
[Q1].Value = "Copyright Date"
[R1].Value = "Student Edition ISBN"
[S1].Value = "Material ID"
[T1].Value = "Pages"
[U1].Value = "Hyperlink"

'Edit 1st column so only Bmk code remains
Range("A1:A6").ClearContents
Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select

Dim cellobject As Range
For Each cellobject In Selection
cellobject.Value = ExtractBmkCode(cellobject.Value)
Next

'Repeat Looptimes
Dim counter
For counter = 1 To Looptimes
'Copy Bmks
Dim colNum As Integer
Dim eCell As Range

Range("A7").Select
Range(Selection, Selection.End(xlDown)).Select
Dim stdsLength As Integer 'length of column that book info will
need to be filled for'
stdsLength = Selection.Count
Selection.Copy
'find the first blank cell in column M to copy into
colNum = 13
ERROR Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Distribute book information
Dim Column_range As Integer
'n = Looptimes
Column_range = counter + 1

Range(Cells(1, Column_range), Cells(6, Column_range)).Select
'you must copy for the paste special to work
Selection.Copy
'find the first blank cell in column N to copy into
colNum = 14
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
Dim startrow As Integer
startrow = Selection.Row

'Select copy Range("N2:S2").Select
Range(Cells(startrow, 14), Cells(startrow, 19)).Select
'Cells(startrow, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:=False, Transpose:=True

' Range("bookpages").Cut
Cells(7, Column_range).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Find the first blank cell in column T to copy to
colNum = 20
Set eCell =
Columns(colNum).SpecialCells(xlCellTypeBlanks).Cel ls(1)
eCell.Select
ActiveSheet.Paste

'Copy book info over for all members of the column.
'how long is column M?
Range(Cells(startrow, 14), Cells((startrow + stdsLength - 1),
19)).FillDown
Next 'counter

'delete old columns - this works, but is commented out until I get the loop
working.
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft

'resize columns to even width
Columns("A:I").ColumnWidth = 12