Patse Rows from one Sheet to another with a Twist

J

John

I am trying to copy values from one sheet to another, to create an effective
small database of information.Thus someone will input values in Sheet1 and a
macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to do so. I first
wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which are in Sheet1 to
Sheet2 in the columns D;E;F;G and H. My code below will do this except it
post them to A; C; H; K; and M. Secondly and its not in my code below, I
want the output values to start posting in the Row below the last value
entered in Sheet2 - otherwise I will just copy over existing data. And
finally I wish to copy values in E6; E9 and E12 to each of the rows that I
copy. So whatever is in E6; E9; E12 will be copied to the row in Sheet2
where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at Row 18 then
skip 5 lines to begin the next row of values to copy i.e. Row 23, but this
row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"), .Range("H18:I18"),
..Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
 
K

KL

Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL
 
J

John

Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the problem, but
I'd prefer to keep them
 
T

Tom Ogilvy

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
 
J

John

Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"
 
K

KL

Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18] and
[M18:R18] (and even [M18:R21] as per your original mesage). There must be
something you are not telling us I am afraid :) Any more merged cells apart
from the ones you have mentioned previously? Any merged cells on the
Database sheet?

Regards,
KL
 
J

John

Hi KL

This is frustrating!. Nope all cells in Database are free from any merged
cells. The peculiar thing is that it post values A18,C18,H18,K18,M18 fine to
Database but get stuck posting E6,E9,E12 (i.e. it doesn't post them and I
get the error), the only thing I might not have mentioned is that cells E6
and E12 are also merged on the Report sheet

Thanks


KL said:
Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18] and
[M18:R18] (and even [M18:R21] as per your original mesage). There must be
something you are not telling us I am afraid :) Any more merged cells
apart from the ones you have mentioned previously? Any merged cells on the
Database sheet?

Regards,
KL


John said:
Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"
Click to expand...
Click to expand...
 
J

John

Also the next range to copy in CopyRng after A18 etc will be A23 etc, not
sure if this is factored within the code I can't determine if its jumping 5
rows, its not A19


John said:
Hi KL

This is frustrating!. Nope all cells in Database are free from any merged
cells. The peculiar thing is that it post values A18,C18,H18,K18,M18 fine
to Database but get stuck posting E6,E9,E12 (i.e. it doesn't post them and
I get the error), the only thing I might not have mentioned is that cells
E6 and E12 are also merged on the Report sheet

Thanks


KL said:
Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18] and
[M18:R18] (and even [M18:R21] as per your original mesage). There must
be something you are not telling us I am afraid :) Any more merged cells
apart from the ones you have mentioned previously? Any merged cells on
the Database sheet?

Regards,
KL


John said:
Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the problem,
but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to do
so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below will
do
this
except it post them to A; C; H; K; and M. Secondly and its not in
my
code
below, I want the output values to start posting in the Row below
the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to each
of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied to
the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at Row
18
then skip 5 lines to begin the next row of values to copy i.e. Row
23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
K

KL

Hi John,
the only thing I might not have mentioned is that cells E6 and E12 are
also merged on the Report sheet
Click to expand...

That' it !!! Can you please explain how they are merged: e.g E6 through E12
or maybe horizontally (then which cells are included?)

Regards,
KL
 
J

John

Aaaahh

Cells E6:G6 and E12:G12

Thanks


KL said:
Hi John,


That' it !!! Can you please explain how they are merged: e.g E6 through
E12 or maybe horizontally (then which cells are included?)

Regards,
KL
Click to expand...
 
K

KL

Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


John said:
Also the next range to copy in CopyRng after A18 etc will be A23 etc, not
sure if this is factored within the code I can't determine if its jumping
5 rows, its not A19


John said:
Hi KL

This is frustrating!. Nope all cells in Database are free from any merged
cells. The peculiar thing is that it post values A18,C18,H18,K18,M18 fine
to Database but get stuck posting E6,E9,E12 (i.e. it doesn't post them
and I get the error), the only thing I might not have mentioned is that
cells E6 and E12 are also merged on the Report sheet

Thanks


KL said:
Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18] and
[M18:R18] (and even [M18:R21] as per your original mesage). There must
be something you are not telling us I am afraid :) Any more merged
cells apart from the ones you have mentioned previously? Any merged
cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to do
so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which are
in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below will
do
this
except it post them to A; C; H; K; and M. Secondly and its not in
my
code
below, I want the output values to start posting in the Row below
the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to each
of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied to
the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at
Row 18
then skip 5 lines to begin the next row of values to copy i.e. Row
23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
J

John

Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc, up to a
max of 10 entries. So my info on the Report goes down as far as Row 63.
Columns A;C;H; K and M are the fields that will be populated for each input
Row. Cells E6;E9 and E12 are only header info which I want on each line/row
within the Database sheet

Thanks


KL said:
Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


John said:
Also the next range to copy in CopyRng after A18 etc will be A23 etc, not
sure if this is factored within the code I can't determine if its jumping
5 rows, its not A19


John said:
Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I might
not have mentioned is that cells E6 and E12 are also merged on the
Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage). There
must be something you are not telling us I am afraid :) Any more
merged cells apart from the ones you have mentioned previously? Any
merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to do
so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which are
in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below will
do
this
except it post them to A; C; H; K; and M. Secondly and its not in
my
code
below, I want the output values to start posting in the Row below
the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to each
of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied to
the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at
Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
K

KL

Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


John said:
Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc, up to
a max of 10 entries. So my info on the Report goes down as far as Row 63.
Columns A;C;H; K and M are the fields that will be populated for each
input Row. Cells E6;E9 and E12 are only header info which I want on each
line/row within the Database sheet

Thanks


KL said:
Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


John said:
Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I might
not have mentioned is that cells E6 and E12 are also merged on the
Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage). There
must be something you are not telling us I am afraid :) Any more
merged cells apart from the ones you have mentioned previously? Any
merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create
an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to do
so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which are
in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its not
in my
code
below, I want the output values to start posting in the Row
below the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied
to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at
Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
J

John

Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine, only 2
Rows of headers are posted, but if only 1 Row I get 65536 rows of Headers

Thanks again


KL said:
Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


John said:
Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc, up to
a max of 10 entries. So my info on the Report goes down as far as Row 63.
Columns A;C;H; K and M are the fields that will be populated for each
input Row. Cells E6;E9 and E12 are only header info which I want on each
line/row within the Database sheet

Thanks


KL said:
Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage).
There must be something you are not telling us I am afraid :) Any
more merged cells apart from the ones you have mentioned previously?
Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create
an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to
do so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which
are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its not
in my
code
below, I want the output values to start posting in the Row
below the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied
to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at
Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
K

KL

Hi John,

Try this:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
On Error Resume Next
rng.Offset(0, -3).Resize(rng.Parent.Cells(65536, "D") _
.End(xlUp).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Sorry for the bug :)

Regards,
KL


John said:
Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine, only 2
Rows of headers are posted, but if only 1 Row I get 65536 rows of Headers

Thanks again


KL said:
Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


John said:
Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc, up
to a max of 10 entries. So my info on the Report goes down as far as Row
63. Columns A;C;H; K and M are the fields that will be populated for
each input Row. Cells E6;E9 and E12 are only header info which I want on
each line/row within the Database sheet

Thanks


Hmmm... This is confusing. Are you saying you need to copy more than
one line from the Report sheet? I had understood that you had the user
input data into a single line (18) on sheet Report and then copy it to
sheet Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage).
There must be something you are not telling us I am afraid :) Any
more merged cells apart from the ones you have mentioned previously?
Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft)
_
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create
an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to
do so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which
are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its not
in my
code
below, I want the output values to start posting in the Row
below the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied
to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1
at Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
J

John

KL your a genius, I'll have to give you the credit to my boss the next pay
review!

Thanks again


KL said:
Hi John,

Try this:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
On Error Resume Next
rng.Offset(0, -3).Resize(rng.Parent.Cells(65536, "D") _
.End(xlUp).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Sorry for the bug :)

Regards,
KL


John said:
Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine, only
2 Rows of headers are posted, but if only 1 Row I get 65536 rows of
Headers

Thanks again


KL said:
Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if
they have other info to enter they will use Row 23, if more, Row 28
etc, up to a max of 10 entries. So my info on the Report goes down as
far as Row 63. Columns A;C;H; K and M are the fields that will be
populated for each input Row. Cells E6;E9 and E12 are only header info
which I want on each line/row within the Database sheet

Thanks


Hmmm... This is confusing. Are you saying you need to copy more than
one line from the Report sheet? I had understood that you had the user
input data into a single line (18) on sheet Report and then copy it to
sheet Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18],
[H18:I18] and [M18:R18] (and even [M18:R21] as per your original
mesage). There must be something you are not telling us I am afraid
:) Any more merged cells apart from the ones you have mentioned
previously? Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft)
_
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to
create an
effective small database of information.Thus someone will
input values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to
do so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which
are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its
not in my
code
below, I want the output values to start posting in the Row
below the
last value entered in Sheet2 - otherwise I will just copy
over existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be
copied to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1
at Row 18
then skip 5 lines to begin the next row of values to copy
i.e. Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
T

Tom Ogilvy

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns
Dim cnt as Long, bEmtpy as Boolean

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
cnt = 0
For r = 0 To 8
bemtpy = True
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
if len(cstr(MyValues(r,c)) <> 0 then bEmtpy = False
Next c
if not bempty then cnt = r + 1
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(cnt, 3) = MyHeaders
End Sub

--
Regards,
Tom Ogilvy





John said:
Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine, only 2
Rows of headers are posted, but if only 1 Row I get 65536 rows of Headers

Thanks again


KL said:
Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


John said:
Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc, up to
a max of 10 entries. So my info on the Report goes down as far as Row 63.
Columns A;C;H; K and M are the fields that will be populated for each
input Row. Cells E6;E9 and E12 are only header info which I want on each
line/row within the Database sheet

Thanks


Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage).
There must be something you are not telling us I am afraid :) Any
more merged cells apart from the ones you have mentioned previously?
Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create
an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to
do so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which
are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its not
in my
code
below, I want the output values to start posting in the Row
below the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied
to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on Sheet1 at
Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
Click to expand...
Click to expand...
Click to expand...
 
T

Tom Ogilvy

Looks like you have your answer, but for completeness, left out a paren:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns
Dim cnt as Long, bEmtpy as Boolean

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
cnt = 0
For r = 0 To 8
bemtpy = True
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
if len(cstr(MyValues(r,c))) <> 0 then bEmtpy = False
Next c
if not bempty then cnt = r + 1
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(cnt, 3) = MyHeaders
End Sub

--
Regards,
Tom Ogilvy


Tom Ogilvy said:
Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns
Dim cnt as Long, bEmtpy as Boolean

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
cnt = 0
For r = 0 To 8
bemtpy = True
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
if len(cstr(MyValues(r,c)) <> 0 then bEmtpy = False
Next c
if not bempty then cnt = r + 1
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(cnt, 3) = MyHeaders
End Sub

--
Regards,
Tom Ogilvy





John said:
Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine, only 2
Rows of headers are posted, but if only 1 Row I get 65536 rows of Headers

Thanks again
Click to expand...
up
to
a max of 10 entries. So my info on the Report goes down as far as Row 63.
Columns A;C;H; K and M are the fields that will be populated for each
input Row. Cells E6;E9 and E12 are only header info which I want on each
line/row within the Database sheet

Thanks


Hmmm... This is confusing. Are you saying you need to copy more than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage).
There must be something you are not telling us I am afraid :) Any
more merged cells apart from the ones you have mentioned previously?
Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow,
Click to expand...
Click to expand...
256).End(xlToLeft)
_
Click to expand...
Sheet1
at
Click to expand...
Click to expand...
 
J

John

Thanks Tom

Tom Ogilvy said:
Looks like you have your answer, but for completeness, left out a paren:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns
Dim cnt as Long, bEmtpy as Boolean

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
cnt = 0
For r = 0 To 8
bemtpy = True
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
if len(cstr(MyValues(r,c))) <> 0 then bEmtpy = False
Next c
if not bempty then cnt = r + 1
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(cnt, 3) = MyHeaders
End Sub

--
Regards,
Tom Ogilvy


Tom Ogilvy said:
Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns
Dim cnt as Long, bEmtpy as Boolean

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
cnt = 0
For r = 0 To 8
bemtpy = True
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
if len(cstr(MyValues(r,c)) <> 0 then bEmtpy = False
Next c
if not bempty then cnt = r + 1
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(cnt, 3) = MyHeaders
End Sub

--
Regards,
Tom Ogilvy





John said:
Hi KL, thanks for all your assistance. It works but just two things

1) How can I get the Headers to post to Columns A,B and C on the Database
(instead of columns I; J and K)

2) If my inputs are anthing less than 2 Rows, the Headers copy to the
Database down to Row 65536. If I post a minimum of 2 Rows its fine,
only 2
Rows of headers are posted, but if only 1 Row I get 65536 rows of Headers

Thanks again


Hi John,

Hope this code would do the trick:

Sub Database_Post()
Dim r As Long, c As Long, rng As Range
Dim MyValues(9, 5), MyHeaders(2), MyColumns

Set rng = Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1, 0)
MyColumns = Array("A", "C", "H", "K", "M")
For r = 0 To 8
For c = 0 To UBound(MyColumns)
MyValues(r, c) = _
Sheets("Report").Cells(18 + 5 * r, MyColumns(c)).Value
Next c
Next r
With Sheets("Report")
MyHeaders(0) = .Range("E6").Value
MyHeaders(1) = .Range("E9").Value
MyHeaders(2) = .Range("E12").Value
End With
rng.Resize(10, 5).Value = MyValues
rng.Offset(0, 5).Resize(rng.Cells(1) _
.End(xlDown).Row - rng.Row + 1, 3) = MyHeaders
End Sub

Regards,
KL


Not quite KL, check the last paragraph in my first post, must not have
explained it correct. The user will input values in Row 18, then if they
have other info to enter they will use Row 23, if more, Row 28 etc,
Click to expand...
up
to
a max of 10 entries. So my info on the Report goes down as far as
Row 63.
Columns A;C;H; K and M are the fields that will be populated for
each
input Row. Cells E6;E9 and E12 are only header info which I want on each
line/row within the Database sheet

Thanks


Hmmm... This is confusing. Are you saying you need to copy more
than one
line from the Report sheet? I had understood that you had the user input
data into a single line (18) on sheet Report and then copy it to sheet
Database as a new row. Wasn't that correct?

Regard,
KL


Also the next range to copy in CopyRng after A18 etc will be A23 etc,
not sure if this is factored within the code I can't determine if its
jumping 5 rows, its not A19


Hi KL

This is frustrating!. Nope all cells in Database are free from
any
merged cells. The peculiar thing is that it post values
A18,C18,H18,K18,M18 fine to Database but get stuck posting E6,E9,E12
(i.e. it doesn't post them and I get the error), the only thing I
might not have mentioned is that cells E6 and E12 are also merged on
the Report sheet

Thanks


Hi John,

Tom's version works perfectly for me if I merge [C18:F18], [H18:I18]
and [M18:R18] (and even [M18:R21] as per your original mesage).
There must be something you are not telling us I am afraid :) Any
more merged cells apart from the ones you have mentioned previously?
Any merged cells on the Database sheet?

Regards,
KL


Thanks Tom

Still gets stuck on the CopyRng.Copy "Cannot change part of merged
cell"

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
Dim cell as Range, i as Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _
Sheets("Report").Range("A18,C18,H18,K18,M18")
Set DestRng = _
Sheets("Database").Cells(65536, "D").End(xlUp).Offset(1,
0)
i = 0
for each cell in CopyRng
DestRng.Offset(0,i).Value = cell
i = i + 1
Next

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow, 256).End(xlToLeft) _
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--
Regards,
Tom Ogilvy


Hi KL, thanks again

It gets stuck on the line CopyRng.Copy

I have merged cells in C-E; H-I and M-R, this seems to be the
problem, but
I'd prefer to keep them


Hi John,

Try this:

Sub Database_Post()
Dim CopyRng As Range, DestRng As Range, CurRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
Set CopyRng = _

Sheets("Report").Range("A18,C18:F18,H18:I18,K18,M18:R18")
Set DestRng = _
Sheets("Database").Cells(65536,
"D").End(xlUp).Offset(1, 0)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues

CurRow = DestRng.Row
Set CopyRng = _
Sheets("Report").Range("E6,E9,E12")
Set DestRng = _
Sheets("Database").Cells(CurRow,
Click to expand...
256).End(xlToLeft)
_
.Offset(0, 1).Resize(1, 3)
CopyRng.Copy
DestRng.PasteSpecial xlPasteValues, , , True

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Regrads,
KL


I am trying to copy values from one sheet to another, to create
an
effective small database of information.Thus someone will input
values
in
Sheet1 and a macro will then copy these to Sheet2.

I have the following code below which I am trying to tweak to
do so. I
first wish to copy A18; C18:F18; H18:I18; K18; M18:R21 which
are in
Sheet1 to Sheet2 in the columns D;E;F;G and H. My code below
will do
this
except it post them to A; C; H; K; and M. Secondly and its not
in my
code
below, I want the output values to start posting in the
Row
below the
last value entered in Sheet2 - otherwise I will just copy over
existing
data. And finally I wish to copy values in E6; E9 and E12 to
each of
the
rows that I copy. So whatever is in E6; E9; E12 will be copied
to the
row
in Sheet2 where the values relating to A18 etc are.

You will notice in my code that I start my copying on
Click to expand...
Sheet1
at
Row 18
then skip 5 lines to begin the next row of values to copy i.e.
Row 23,
but this row 23 needs to be posted in Row 2 on Sheet2

Hope someone can help

Thanks




Sub Database_Post()

Application.ScreenUpdating = False

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Sheets("Database").Select
Range("A1").Select

Dim I As Long, j As Long, k As Long, l As Long
Dim rng As Range, cell As Range
With Worksheets("Report")
Set rng = Union(.Range("A18"), .Range("C18:F18"),
.Range("H18:I18"),
.Range("K18"), .Range("M18:R21"))

I = 0
j = 0
l = 0
For Each cell In rng
j = cell.Row
k = 1
l = l + 1
Do While Not IsEmpty(.Cells(j, cell.Column))
.Cells(j, cell.Column).Copy
Worksheets("Database") _
.Cells(k, l).PasteSpecial xlValues
k = k + 1
j = j + 5
Loop
Next
End With



Sheets("Database").Select

Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
Range("A1").Select

Sheets("Report").Select
Range("A1").Select


With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Application.ScreenUpdating = True


End Sub
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

Inaccurate count with code 6
Loop returns only one value, does not loop & an assignment to columnhow-to problem. 26
Development combinations with exclusion of columns 0
Development combinations with exclusion of columns 0
Macro to Combine Data from Multiple Sheets with Cell References 4
Copying Data from One sheet to another 6
Somewhat complex code to copy data from one sheet to another 9
Adding selected items from one list box to two different list boxe 6

Top