Can anyone clean this code?

fidgen

New Member
Joined
Aug 20, 2002
Messages
46
Hiya, I've made the following to jig some excel worksheets around into a format more useful for SPSS analysis, but the code (as you can see) is hardly elegant in its simplicity and so take a few seconds more than it should to execute. Can anyone suggest a cleaner way of executing the large messy middle section?

Thanks
hugh





****************************************
========================================


Sub SPSSoutput()

Dim A As Integer
Dim B As Byte, D As Byte, E As Byte


For B = 1 To 7

For A = 2 To 5000
If Sheets(1).Cells(A, 1) = "" Then
Exit For
End If

Sheets(2).Cells(A, B) = Sheets(1).Cells(A, B)
D = 8
E = 9
Sheets(2).Cells(A, D + 0) = Sheets(1).Cells(A + 0, E + 0)
Sheets(2).Cells(A, D + 1) = Sheets(1).Cells(A + 1, E + 0)
Sheets(2).Cells(A, D + 2) = Sheets(1).Cells(A + 2, E + 0)
Sheets(2).Cells(A, D + 3) = Sheets(1).Cells(A + 0, E + 1)
Sheets(2).Cells(A, D + 4) = Sheets(1).Cells(A + 1, E + 1)
Sheets(2).Cells(A, D + 5) = Sheets(1).Cells(A + 2, E + 1)
Sheets(2).Cells(A, D + 6) = Sheets(1).Cells(A + 0, E + 2)
Sheets(2).Cells(A, D + 7) = Sheets(1).Cells(A + 1, E + 2)
Sheets(2).Cells(A, D + :cool: = Sheets(1).Cells(A + 2, E + 2)
Sheets(2).Cells(A, D + 9) = Sheets(1).Cells(A + 0, E + 3)
Sheets(2).Cells(A, D + 10) = Sheets(1).Cells(A + 1, E + 3)
Sheets(2).Cells(A, D + 11) = Sheets(1).Cells(A + 2, E + 3)
Sheets(2).Cells(A, D + 12) = Sheets(1).Cells(A + 0, E + 4)
Sheets(2).Cells(A, D + 13) = Sheets(1).Cells(A + 1, E + 4)
Sheets(2).Cells(A, D + 14) = Sheets(1).Cells(A + 2, E + 4)
Sheets(2).Cells(A, D + 15) = Sheets(1).Cells(A + 0, E + 5)
Sheets(2).Cells(A, D + 16) = Sheets(1).Cells(A + 1, E + 5)
Sheets(2).Cells(A, D + 17) = Sheets(1).Cells(A + 2, E + 5)
Sheets(2).Cells(A, D + 18) = Sheets(1).Cells(A + 0, E + 6)
Sheets(2).Cells(A, D + 19) = Sheets(1).Cells(A + 1, E + 6)
Sheets(2).Cells(A, D + 20) = Sheets(1).Cells(A + 2, E + 6)
Sheets(2).Cells(A, D + 21) = Sheets(1).Cells(A + 0, E + 7)
Sheets(2).Cells(A, D + 22) = Sheets(1).Cells(A + 1, E + 7)
Sheets(2).Cells(A, D + 23) = Sheets(1).Cells(A + 2, E + 7)
Sheets(2).Cells(A, D + 24) = Sheets(1).Cells(A + 0, E + :cool:
Sheets(2).Cells(A, D + 25) = Sheets(1).Cells(A + 1, E + :cool:
Sheets(2).Cells(A, D + 26) = Sheets(1).Cells(A + 2, E + :cool:
Sheets(2).Cells(A, D + 27) = Sheets(1).Cells(A + 0, E + 9)
Sheets(2).Cells(A, D + 28) = Sheets(1).Cells(A + 1, E + 9)
Sheets(2).Cells(A, D + 29) = Sheets(1).Cells(A + 2, E + 9)
Sheets(2).Cells(A, D + 30) = Sheets(1).Cells(A + 0, E + 10)
Sheets(2).Cells(A, D + 31) = Sheets(1).Cells(A + 1, E + 10)
Sheets(2).Cells(A, D + 32) = Sheets(1).Cells(A + 2, E + 10)
Sheets(2).Cells(A, D + 33) = Sheets(1).Cells(A + 0, E + 11)
Sheets(2).Cells(A, D + 34) = Sheets(1).Cells(A + 1, E + 11)
Sheets(2).Cells(A, D + 35) = Sheets(1).Cells(A + 2, E + 11)
Sheets(2).Cells(A, D + 36) = Sheets(1).Cells(A + 0, E + 12)
Sheets(2).Cells(A, D + 37) = Sheets(1).Cells(A + 1, E + 12)
Sheets(2).Cells(A, D + 38) = Sheets(1).Cells(A + 2, E + 12)
Sheets(2).Cells(A, D + 39) = Sheets(1).Cells(A + 0, E + 13)
Sheets(2).Cells(A, D + 40) = Sheets(1).Cells(A + 1, E + 13)
Sheets(2).Cells(A, D + 41) = Sheets(1).Cells(A + 2, E + 13)
Sheets(2).Cells(A, D + 42) = Sheets(1).Cells(A + 0, E + 14)
Sheets(2).Cells(A, D + 43) = Sheets(1).Cells(A + 1, E + 14)
Sheets(2).Cells(A, D + 44) = Sheets(1).Cells(A + 2, E + 14)
Sheets(2).Cells(A, D + 45) = Sheets(1).Cells(A + 0, E + 15)
Sheets(2).Cells(A, D + 46) = Sheets(1).Cells(A + 1, E + 15)
Sheets(2).Cells(A, D + 47) = Sheets(1).Cells(A + 2, E + 15)
Sheets(2).Cells(A, D + 48) = Sheets(1).Cells(A + 0, E + 16)
Sheets(2).Cells(A, D + 49) = Sheets(1).Cells(A + 1, E + 16)
Sheets(2).Cells(A, D + 50) = Sheets(1).Cells(A + 2, E + 16)
Sheets(2).Cells(A, D + 51) = Sheets(1).Cells(A + 0, E + 17)
Sheets(2).Cells(A, D + 52) = Sheets(1).Cells(A + 1, E + 17)
Sheets(2).Cells(A, D + 53) = Sheets(1).Cells(A + 2, E + 17)
Sheets(2).Cells(A, D + 54) = Sheets(1).Cells(A + 0, E + 18)
Sheets(2).Cells(A, D + 55) = Sheets(1).Cells(A + 1, E + 18)
Sheets(2).Cells(A, D + 56) = Sheets(1).Cells(A + 2, E + 18)
Sheets(2).Cells(A, D + 57) = Sheets(1).Cells(A + 0, E + 19)
Sheets(2).Cells(A, D + 58) = Sheets(1).Cells(A + 1, E + 19)
Sheets(2).Cells(A, D + 59) = Sheets(1).Cells(A + 2, E + 19)
Sheets(2).Cells(A, D + 60) = Sheets(1).Cells(A + 0, E + 20)
Sheets(2).Cells(A, D + 61) = Sheets(1).Cells(A + 1, E + 20)
Sheets(2).Cells(A, D + 62) = Sheets(1).Cells(A + 2, E + 20)
Sheets(2).Cells(A, D + 63) = Sheets(1).Cells(A + 0, E + 21)
Sheets(2).Cells(A, D + 64) = Sheets(1).Cells(A + 1, E + 21)
Sheets(2).Cells(A, D + 65) = Sheets(1).Cells(A + 2, E + 21)
Sheets(2).Cells(A, D + 66) = Sheets(1).Cells(A + 0, E + 22)
Sheets(2).Cells(A, D + 67) = Sheets(1).Cells(A + 1, E + 22)
Sheets(2).Cells(A, D + 68) = Sheets(1).Cells(A + 2, E + 22)
Sheets(2).Cells(A, D + 69) = Sheets(1).Cells(A + 0, E + 23)
Sheets(2).Cells(A, D + 70) = Sheets(1).Cells(A + 1, E + 23)
Sheets(2).Cells(A, D + 71) = Sheets(1).Cells(A + 2, E + 23)


A = A + 2

Next 'a
Next 'b

Cells.Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom


End Sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

fidgen

New Member
Joined
Aug 20, 2002
Messages
46
I've added

Application.ScreenUpdating = False

which has shaved a second or 2 off!
 

Richie(UK)

MrExcel MVP
Joined
May 17, 2002
Messages
3,329
Hi fidgen,

Depending on the format of your workbook, you may also like to consider adding Application.Calculation = xlCalculateManual to the beginning of your code.

(Switch back to Automatic at the end)

HTH
 

Forum statistics

Threads
1,144,770
Messages
5,726,186
Members
422,661
Latest member
foxleinlady

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top