[SOLVED] Patse Rows from one Sheet to another with a Twist

John · 08-06-2005, 04:05 PM

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

KL · 08-06-2005, 05:05 PM

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

"John" <[email protected]> wrote in message
news:[email protected]...
>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
>
>
>

John · 08-06-2005, 06:05 PM

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

"KL" <[email protected]> wrote in message
news:u%[email protected]...
> 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
>
>
> "John" <[email protected]> wrote in message
> news:[email protected]...
>>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
>>
>>
>>
>
>

Tom Ogilvy · 08-06-2005, 07:05 PM

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

"John" <[email protected]> wrote in message
news:[email protected]...
> 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
>
>
> "KL" <[email protected]> wrote in message
> news:u%[email protected]...
> > 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
> >
> >
> > "John" <[email protected]> wrote in message
> > news:[email protected]...
> >>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
> >>
> >>
> >>
> >
> >
>
>

John · 08-07-2005, 04:05 AM

Thanks Tom

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

"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> 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
>
>
> "John" <[email protected]> wrote in message
> news:[email protected]...
>> 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
>>
>>
>> "KL" <[email protected]> wrote in message
>> news:u%[email protected]...
>> > 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
>> >
>> >
>> > "John" <[email protected]> wrote in message
>> > news:[email protected]...
>> >>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
>> >>
>> >>
>> >>
>> >
>> >
>>
>>
>
>

KL · 08-07-2005, 05:05 AM

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" <[email protected]> wrote in message
news:[email protected]...
> Thanks Tom
>
> Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"
>
> "Tom Ogilvy" <[email protected]> wrote in message
> news:[email protected]...
>> 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
>>
>>
>> "John" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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
>>>
>>>
>>> "KL" <[email protected]> wrote in message
>>> news:u%[email protected]...
>>> > 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
>>> >
>>> >
>>> > "John" <[email protected]> wrote in message
>>> > news:[email protected]...
>>> >>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
>>> >>
>>> >>
>>> >>
>>> >
>>> >
>>>
>>>
>>
>>
>
>

John · 08-07-2005, 06:05 AM

Aaaahh

Cells E6:G6 and E12:G12

Thanks

"KL" <[email protected]> wrote in message
news:[email protected]...
> Hi John,
>
>> the only thing I might not have mentioned is that cells E6 and E12 are
>> also merged on the Report sheet
>
> 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
>
>

John · 08-07-2005, 06:05 AM

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" <[email protected]> wrote in message
news:%[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> Thanks Tom
>>>>>
>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>>> cell"
>>>>>
>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> 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
>>>>>>
>>>>>>
>>>>>> "John" <[email protected]> wrote in message
>>>>>> news:[email protected]...
>>>>>>> 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
>>>>>>>
>>>>>>>
>>>>>>> "KL" <[email protected]> wrote in message
>>>>>>> news:u%[email protected]...
>>>>>>> > 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
>>>>>>> >
>>>>>>> >
>>>>>>> > "John" <[email protected]> wrote in message
>>>>>>> > news:[email protected]...
>>>>>>> >>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
>>>>>>> >>
>>>>>>> >>
>>>>>>> >>
>>>>>>> >
>>>>>>> >
>>>>>>>
>>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

KL · 08-07-2005, 06:05 AM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> Thanks Tom
>>>>
>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>> cell"
>>>>
>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> 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
>>>>>
>>>>>
>>>>> "John" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> 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
>>>>>>
>>>>>>
>>>>>> "KL" <[email protected]> wrote in message
>>>>>> news:u%[email protected]...
>>>>>> > 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
>>>>>> >
>>>>>> >
>>>>>> > "John" <[email protected]> wrote in message
>>>>>> > news:[email protected]...
>>>>>> >>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
>>>>>> >>
>>>>>> >>
>>>>>> >>
>>>>>> >
>>>>>> >
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

KL · 08-07-2005, 06:05 AM

Hi John,

> the only thing I might not have mentioned is that cells E6 and E12 are
> also merged on the Report sheet

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

John · 08-07-2005, 06:05 AM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> Thanks Tom
>>>
>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"
>>>
>>> "Tom Ogilvy" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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
>>>>
>>>>
>>>> "John" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> 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
>>>>>
>>>>>
>>>>> "KL" <[email protected]> wrote in message
>>>>> news:u%[email protected]...
>>>>> > 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
>>>>> >
>>>>> >
>>>>> > "John" <[email protected]> wrote in message
>>>>> > news:[email protected]...
>>>>> >>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
>>>>> >>
>>>>> >>
>>>>> >>
>>>>> >
>>>>> >
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

John · 08-07-2005, 06:05 AM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> Thanks Tom
>>
>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged cell"
>>
>> "Tom Ogilvy" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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
>>>
>>>
>>> "John" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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
>>>>
>>>>
>>>> "KL" <[email protected]> wrote in message
>>>> news:u%[email protected]...
>>>> > 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
>>>> >
>>>> >
>>>> > "John" <[email protected]> wrote in message
>>>> > news:[email protected]...
>>>> >>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
>>>> >>
>>>> >>
>>>> >>
>>>> >
>>>> >
>>>>
>>>>
>>>
>>>
>>
>>
>
>

KL · 08-07-2005, 10:05 AM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:%[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> 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" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> Thanks Tom
>>>>>>
>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>>>> cell"
>>>>>>
>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>>>> news:[email protected]...
>>>>>>> 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
>>>>>>>
>>>>>>>
>>>>>>> "John" <[email protected]> wrote in message
>>>>>>> news:[email protected]...
>>>>>>>> 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
>>>>>>>>
>>>>>>>>
>>>>>>>> "KL" <[email protected]> wrote in message
>>>>>>>> news:u%[email protected]...
>>>>>>>> > 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
>>>>>>>> >
>>>>>>>> >
>>>>>>>> > "John" <[email protected]> wrote in message
>>>>>>>> > news:[email protected]...
>>>>>>>> >>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
>>>>>>>> >>
>>>>>>>> >>
>>>>>>>> >>
>>>>>>>> >
>>>>>>>> >
>>>>>>>>
>>>>>>>>
>>>>>>>
>>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

John · 08-07-2005, 04:05 PM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:%[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> 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" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> 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" <[email protected]> wrote in message
>>>>>> news:[email protected]...
>>>>>>> Thanks Tom
>>>>>>>
>>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>>>>> cell"
>>>>>>>
>>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>>>>> news:[email protected]...
>>>>>>>> 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
>>>>>>>>
>>>>>>>>
>>>>>>>> "John" <[email protected]> wrote in message
>>>>>>>> news:[email protected]...
>>>>>>>>> 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
>>>>>>>>>
>>>>>>>>>
>>>>>>>>> "KL" <[email protected]> wrote in message
>>>>>>>>> news:u%[email protected]...
>>>>>>>>> > 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
>>>>>>>>> >
>>>>>>>>> >
>>>>>>>>> > "John" <[email protected]> wrote in message
>>>>>>>>> > news:[email protected]...
>>>>>>>>> >>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
>>>>>>>>> >>
>>>>>>>>> >>
>>>>>>>>> >>
>>>>>>>>> >
>>>>>>>>> >
>>>>>>>>>
>>>>>>>>>
>>>>>>>>
>>>>>>>>
>>>>>>>
>>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

KL · 08-07-2005, 04:05 PM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:%[email protected]...
>>>> 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" <[email protected]> wrote in message
>>>> news:[email protected]...
>>>>> 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" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> 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" <[email protected]> wrote in message
>>>>>> news:[email protected]...
>>>>>>> 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" <[email protected]> wrote in message
>>>>>>> news:[email protected]...
>>>>>>>> Thanks Tom
>>>>>>>>
>>>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>>>>>> cell"
>>>>>>>>
>>>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>>>>>> news:[email protected]...
>>>>>>>>> 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
>>>>>>>>>
>>>>>>>>>
>>>>>>>>> "John" <[email protected]> wrote in message
>>>>>>>>> news:[email protected]...
>>>>>>>>>> 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
>>>>>>>>>>
>>>>>>>>>>
>>>>>>>>>> "KL" <[email protected]> wrote in message
>>>>>>>>>> news:u%[email protected]...
>>>>>>>>>> > 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
>>>>>>>>>> >
>>>>>>>>>> >
>>>>>>>>>> > "John" <[email protected]> wrote in message
>>>>>>>>>> > news:[email protected]...
>>>>>>>>>> >>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
>>>>>>>>>> >>
>>>>>>>>>> >>
>>>>>>>>>> >>
>>>>>>>>>> >
>>>>>>>>>> >
>>>>>>>>>>
>>>>>>>>>>
>>>>>>>>>
>>>>>>>>>
>>>>>>>>
>>>>>>>>
>>>>>>>
>>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

John · 08-07-2005, 04:05 PM

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

Thanks again

"KL" <[email protected]> wrote in message
news:%[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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" <[email protected]> wrote in message
>>> news:[email protected]...
>>>> 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" <[email protected]> wrote in message
>>>> news:%[email protected]...
>>>>> 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" <[email protected]> wrote in message
>>>>> news:[email protected]...
>>>>>> 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" <[email protected]> wrote in message
>>>>>> news:[email protected]...
>>>>>>> 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" <[email protected]> wrote in message
>>>>>>> news:[email protected]...
>>>>>>>> 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" <[email protected]> wrote in message
>>>>>>>> news:[email protected]...
>>>>>>>>> Thanks Tom
>>>>>>>>>
>>>>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
>>>>>>>>> cell"
>>>>>>>>>
>>>>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>>>>>>>>> news:[email protected]...
>>>>>>>>>> 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
>>>>>>>>>>
>>>>>>>>>>
>>>>>>>>>> "John" <[email protected]> wrote in message
>>>>>>>>>> news:[email protected]...
>>>>>>>>>>> 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
>>>>>>>>>>>
>>>>>>>>>>>
>>>>>>>>>>> "KL" <[email protected]> wrote in message
>>>>>>>>>>> news:u%[email protected]...
>>>>>>>>>>> > 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
>>>>>>>>>>> >
>>>>>>>>>>> >
>>>>>>>>>>> > "John" <[email protected]> wrote in message
>>>>>>>>>>> > news:[email protected]...
>>>>>>>>>>> >>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
>>>>>>>>>>> >>
>>>>>>>>>>> >>
>>>>>>>>>>> >>
>>>>>>>>>>> >
>>>>>>>>>>> >
>>>>>>>>>>>
>>>>>>>>>>>
>>>>>>>>>>
>>>>>>>>>>
>>>>>>>>>
>>>>>>>>>
>>>>>>>>
>>>>>>>>
>>>>>>>
>>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>

Tom Ogilvy · 08-07-2005, 04:05 PM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
> > 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" <[email protected]> wrote in message
> > news:[email protected]...
> >> 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" <[email protected]> wrote in message
> >> news:%[email protected]...
> >>> 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" <[email protected]> wrote in message
> >>> news:[email protected]...
> >>>> 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" <[email protected]> wrote in message
> >>>> news:[email protected]...
> >>>>> 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" <[email protected]> wrote in message
> >>>>> news:[email protected]...
> >>>>>> 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" <[email protected]> wrote in message
> >>>>>> news:[email protected]...
> >>>>>>> Thanks Tom
> >>>>>>>
> >>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of merged
> >>>>>>> cell"
> >>>>>>>
> >>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
> >>>>>>> news:[email protected]...
> >>>>>>>> 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
> >>>>>>>>
> >>>>>>>>
> >>>>>>>> "John" <[email protected]> wrote in message
> >>>>>>>> news:[email protected]...
> >>>>>>>>> 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
> >>>>>>>>>
> >>>>>>>>>
> >>>>>>>>> "KL" <[email protected]> wrote in message
> >>>>>>>>> news:u%[email protected]...
> >>>>>>>>> > 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
> >>>>>>>>> >
> >>>>>>>>> >
> >>>>>>>>> > "John" <[email protected]> wrote in message
> >>>>>>>>> > news:[email protected]...
> >>>>>>>>> >>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
> >>>>>>>>> >>
> >>>>>>>>> >>
> >>>>>>>>> >>
> >>>>>>>>> >
> >>>>>>>>> >
> >>>>>>>>>
> >>>>>>>>>
> >>>>>>>>
> >>>>>>>>
> >>>>>>>
> >>>>>>>
> >>>>>>
> >>>>>>
> >>>>>
> >>>>>
> >>>>
> >>>>
> >>>
> >>>
> >>
> >>
> >
> >
>
>

Tom Ogilvy · 08-07-2005, 05:05 PM

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" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
> > 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" <[email protected]> wrote in message
> > news:[email protected]...
> > > 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" <[email protected]> wrote in message
> > > news:[email protected]...
> > >> 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" <[email protected]> wrote in message
> > >> news:%[email protected]...
> > >>> 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" <[email protected]> wrote in message
> > >>> news:[email protected]...
> > >>>> 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" <[email protected]> wrote in message
> > >>>> news:[email protected]...
> > >>>>> 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" <[email protected]> wrote in message
> > >>>>> news:[email protected]...
> > >>>>>> 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" <[email protected]> wrote in message
> > >>>>>> news:[email protected]...
> > >>>>>>> Thanks Tom
> > >>>>>>>
> > >>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of
merged
> > >>>>>>> cell"
> > >>>>>>>
> > >>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
> > >>>>>>> news:[email protected]...
> > >>>>>>>> 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
> > >>>>>>>>
> > >>>>>>>>
> > >>>>>>>> "John" <[email protected]> wrote in message
> > >>>>>>>> news:[email protected]...
> > >>>>>>>>> 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
> > >>>>>>>>>
> > >>>>>>>>>
> > >>>>>>>>> "KL" <[email protected]> wrote in message
> > >>>>>>>>> news:u%[email protected]...
> > >>>>>>>>> > 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
> > >>>>>>>>> >
> > >>>>>>>>> >
> > >>>>>>>>> > "John" <[email protected]> wrote in message
> > >>>>>>>>> > news:[email protected]...
> > >>>>>>>>> >>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
> > >>>>>>>>> >>
> > >>>>>>>>> >>
> > >>>>>>>>> >>
> > >>>>>>>>> >
> > >>>>>>>>> >
> > >>>>>>>>>
> > >>>>>>>>>
> > >>>>>>>>
> > >>>>>>>>
> > >>>>>>>
> > >>>>>>>
> > >>>>>>
> > >>>>>>
> > >>>>>
> > >>>>>
> > >>>>
> > >>>>
> > >>>
> > >>>
> > >>
> > >>
> > >
> > >
> >
> >
>
>

John · 08-08-2005, 02:05 AM

Thanks Tom

"Tom Ogilvy" <[email protected]> wrote in message
news:%[email protected]...
> 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" <[email protected]> wrote in message
> news:[email protected]...
>> 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" <[email protected]> wrote in message
>> news:[email protected]...
>> > 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" <[email protected]> wrote in message
>> > news:[email protected]...
>> > > 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" <[email protected]> wrote in message
>> > > news:[email protected]...
>> > >> 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" <[email protected]> wrote in message
>> > >> news:%[email protected]...
>> > >>> 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" <[email protected]> wrote in message
>> > >>> news:[email protected]...
>> > >>>> 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" <[email protected]> wrote in message
>> > >>>> news:[email protected]...
>> > >>>>> 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" <[email protected]> wrote in message
>> > >>>>> news:[email protected]...
>> > >>>>>> 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" <[email protected]> wrote in message
>> > >>>>>> news:[email protected]...
>> > >>>>>>> Thanks Tom
>> > >>>>>>>
>> > >>>>>>> Still gets stuck on the CopyRng.Copy "Cannot change part of
> merged
>> > >>>>>>> cell"
>> > >>>>>>>
>> > >>>>>>> "Tom Ogilvy" <[email protected]> wrote in message
>> > >>>>>>> news:[email protected]...
>> > >>>>>>>> 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
>> > >>>>>>>>
>> > >>>>>>>>
>> > >>>>>>>> "John" <[email protected]> wrote in message
>> > >>>>>>>> news:[email protected]...
>> > >>>>>>>>> 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
>> > >>>>>>>>>
>> > >>>>>>>>>
>> > >>>>>>>>> "KL" <[email protected]> wrote in message
>> > >>>>>>>>> news:u%[email protected]...
>> > >>>>>>>>> > 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
>> > >>>>>>>>> >
>> > >>>>>>>>> >
>> > >>>>>>>>> > "John" <[email protected]> wrote in message
>> > >>>>>>>>> > news:[email protected]...
>> > >>>>>>>>> >>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
>> > >>>>>>>>> >>
>> > >>>>>>>>> >>
>> > >>>>>>>>> >>
>> > >>>>>>>>> >
>> > >>>>>>>>> >
>> > >>>>>>>>>
>> > >>>>>>>>>
>> > >>>>>>>>
>> > >>>>>>>>
>> > >>>>>>>
>> > >>>>>>>
>> > >>>>>>
>> > >>>>>>
>> > >>>>>
>> > >>>>>
>> > >>>>
>> > >>>>
>> > >>>
>> > >>>
>> > >>
>> > >>
>> > >
>> > >
>> >
>> >
>>
>>
>
>

[SOLVED] Patse Rows from one Sheet to another with a Twist

LinkBack

Thread Tools

Display

[SOLVED] Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Re: Patse Rows from one Sheet to another with a Twist

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions