Help! Why doesn't this work after 2 times?

W

WestWingFan

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).Cells(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).Cells(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).Cells(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
 
J

Joel

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

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


WestWingFan said:
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).Cells(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).Cells(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).Cells(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
Click to expand...
 
W

WestWingFan

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 said:
It is always a good idea to check if code return a value beofre preceeding

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


WestWingFan said:
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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
 
J

Joel

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 said:
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 said:
It is always a good idea to check if code return a value beofre preceeding

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


WestWingFan said:
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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
W

WestWingFan

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 said:
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 said:
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 said:
It is always a good idea to check if code return a value beofre preceeding

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

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

WestWingFan said:
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 said:
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 said:
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?

:

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

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
W

WestWingFan

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

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

WestWingFan said:
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 said:
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

:

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?

:

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

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

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

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

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

WestWingFan said:
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.

:

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

:

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?

:

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

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
W

WestWingFan

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 said:
What data is in the cell? Is there anything special about the cell like
being a merged cell?

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

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

:

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.

:

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

:

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?

:

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

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

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 said:
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 said:
What data is in the cell? Is there anything special about the cell like
being a merged cell?

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

:

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

:

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.

:

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

:

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?

:

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

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


:

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).Cells(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).Cells(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).Cells(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
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel 2013 Merge Data 2
Eliminate blanks while copy row and transpose 11
InputBox for column letter problem 2
Help in sorting data 2
works in 2007 but not in 2010 0
Loop is slow trying array code 17
Code to copy column in sheet 1 to column in sheet 2 based on matched criteria 0
Calculating(Processors(2)): % 1

Top