Code Cleanup after coping cells

[jupops]

Good Evening All

Could you advise me on how to clean up the following code. I am trying to copy a set of range of cells from a sheet called ‘spool’ to sheet 1 but transpose the cells, so D14 will be copied to B2,C2,D2 and E2. Then the next E1:E4 will be copied F2.G2.H2,I2, then F1:F4 will go to J2,K2,L2,M2 and G1:G4 will go to N2,O2,P2 and finally Q2. I then move to the next line so D58 will be copied to B3,C3,D3,E3 and so on until the end of the document on spool sheet

Regards
Jupops

The code looks like:

Range("D14&quot.Select
Selection.Copy
Sheets("Sheet1&quot.Select
Range("B2&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("F2&quot.Select
Sheets("spool&quot.Select
Range("E1:E4&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("F1:F4&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("J2&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("G1:G4&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("N2&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("D58&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("B3&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("E5:E8&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("F3&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("F5:F8&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("J3&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("spool&quot.Select
Range("G5:G8&quot.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1&quot.Select
Range("N3&quot.Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End Sub

 

[SkipVought]

Hi,

How 'bout this...

Sub testt()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("spool")
    Set ws2 = Worksheets("Sheet1")
    
    ws1.Range("D1:D4").Copy
    ws2.Range("B2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("E1:E4").Copy
    ws2.Range("F2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("F1:F4").Copy
    ws2.Range("J2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("G1:G4").Copy
    ws2.Range("N2").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("D5:D8").Copy
    ws2.Range("B3").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("E5:E8").Copy
    ws2.Range("F3").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("F5:F8").Copy
    ws2.Range("J3").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
    ws1.Range("G5:G8").Copy
    ws2.Range("N3").PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
        , Transpose:=True
End Sub

Hope this helps

Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[Zathras]

I generally find that if you put a little structure into the code it becomes easier to maintain and debug. Try this:
[blue]

Option Explicit
Const SHEET_SOURCE = "Spool"
Const SHEET_TARGET = "Sheet1"

Sub CopyAll()
  Application.ScreenUpdating = False
  Call CopyFromSpool("D1:D4", "B2")
  Call CopyFromSpool("E1:E4", "F2")
  Call CopyFromSpool("F1:F4", "J2")
  Call CopyFromSpool("G1:G4", "N2")
  Call CopyFromSpool("D5:D8", "B3")
  Call CopyFromSpool("E5:E8", "F3")
  Call CopyFromSpool("F5:F8", "J3")
  Call CopyFromSpool("G5:G8", "N3")
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Sub CopyFromSpool(Source As String, Destination As String)
  Worksheets(SHEET_SOURCE).Range(Source).Copy
  Worksheets(SHEET_TARGET).Range(Destination).PasteSpecial _
             Transpose:=True
End Sub

[/color]