Repeating Reformatting Macro

[New2VBA]

Project just got tossed to me with little or no IT backup. Need to
write a macro that will take data from columns "A" and "B" (3000+ rows
worth), 52 rows at a time and paste it into rows "D" and "E" leaving
"C" empty. This needs to be repeated so that the next 52 rows of data
skip "F: and get pasted into "G" and "H". The values in A1:B1 also
need to be placed in cells at the top of these pasted columns. Lastly,
I need it to know when to stop automatically. If someone could point
me towards examples that do any or all parts of this, I would greatly
appreciate it.

THANKS!

[Jim Thomlinson]

Here is some code...

Private Const IntRows As Integer = 52
Private Const intColumns As Integer = 3

Sub MoveRows()
Dim wksFrom As Worksheet
Dim wksTo As Worksheet
Dim rngFrom As Range
Dim rngToData As Range
Dim rngToTitles As Range
Dim rngTitles As Range
Dim rngLastItem As Range

Set wksFrom = Sheets("Sheet2") 'Change The Sheet Name
Set wksTo = Worksheets.Add
Set rngTitles = wksFrom.Range("A1:B1")
Set rngToTitles = wksTo.Range("A1")
Set rngLastItem = wksFrom.Range("A65536").End(xlUp)
Set rngFrom = wksFrom.Range(wksFrom.Cells(2, 1), wksFrom.Cells(IntRows +
1, 2))
Set rngToData = wksTo.Range("A2")

Do While Intersect(rngFrom, rngLastItem) Is Nothing
rngFrom.Copy rngToData
rngTitles.Copy rngToTitles
Set rngFrom = rngFrom.Offset(IntRows, 0)
Set rngToData = rngToData.Offset(IntRows, intColumns)
Set rngToTitles = rngToTitles.Offset(0, intColumns)
Loop
End Sub

--
HTH...

Jim Thomlinson


"New2VBA" wrote:

> Project just got tossed to me with little or no IT backup. Need to
> write a macro that will take data from columns "A" and "B" (3000+ rows
> worth), 52 rows at a time and paste it into rows "D" and "E" leaving
> "C" empty. This needs to be repeated so that the next 52 rows of data
> skip "F: and get pasted into "G" and "H". The values in A1:B1 also
> need to be placed in cells at the top of these pasted columns. Lastly,
> I need it to know when to stop automatically. If someone could point
> me towards examples that do any or all parts of this, I would greatly
> appreciate it.
>
> THANKS!
>
>

[New2VBA]

I wish I could say it looks good, but I don't understand much. I do
know however that it is not working. I get an error message: "Compile
Error - Expected End Sub"

Let me know what I am missing.

Thanks

[Jim Thomlinson]

Give this a try. Make sure the constants are at the very top of the code
module. It is the exact same code just re-arranged a bit. It compiles at this
end so it should be ok...

Private Const IntRows As Integer = 52 'Must be at top of code window
Private Const intColumns As Integer = 3 'Must be at top of code window

Sub MoveRows()
Dim wksFrom As Worksheet
Dim wksTo As Worksheet
Dim rngFrom As Range
Dim rngToData As Range
Dim rngToTitles As Range
Dim rngTitles As Range
Dim rngLastItem As Range

Set wksFrom = Sheets("Sheet2") 'Change The Sheet Name
Set wksTo = Worksheets.Add
Set rngTitles = wksFrom.Range("A1:B1")
Set rngToTitles = wksTo.Range("A1")
Set rngLastItem = wksFrom.Range("A65536").End(xlUp)
Set rngFrom = wksFrom.Range(wksFrom.Cells(2, 1), _
wksFrom.Cells(IntRows + 1, 2))
Set rngToData = wksTo.Range("A2")

Do While Intersect(rngFrom, rngLastItem) Is Nothing
rngFrom.Copy rngToData
rngTitles.Copy rngToTitles
Set rngFrom = rngFrom.Offset(IntRows, 0)
Set rngToData = rngToData.Offset(IntRows, intColumns)
Set rngToTitles = rngToTitles.Offset(0, intColumns)
Loop
End Sub


--
HTH...

Jim Thomlinson


"New2VBA" wrote:

> I wish I could say it looks good, but I don't understand much. I do
> know however that it is not working. I get an error message: "Compile
> Error - Expected End Sub"
>
> Let me know what I am missing.
>
> Thanks
>
>

[New2VBA]

Still not working. Same error message.

[Jim Thomlinson]

It compiles at my end. give this a try. Open a brand new workbook and paste
the code into one of the sheets or into a module and select Debug -> Compile
VBA Project
--
HTH...

Jim Thomlinson


"New2VBA" wrote:

> Still not working. Same error message.
>
>

[Jim Thomlinson]

I trust things are working now?
--
HTH...

Jim Thomlinson


"New2VBA" wrote:

> Still not working. Same error message.
>
>

[New2VBA]

Hi Jim,

Thanks for all your help, but I am still getting an error message. The
following line of code seems to halt the execution.

Set rngLastItem =3D wksFrom.Range("A3274").End(xl=ADUp)

Any help you can offer would be great.

Thanks!

[New2VBA]

Ok, I got that line fixed. All my fault (copied with an error). Works
great with one small issue. I need all the columns to start at the 2nd
row. This has done a great job of shifting them to the right, but
doesn't bring them to the top.

Thanks,
Angela