Copy Multiple Cells to an Ordered List & Clear

T

twothings

Board Regular
Joined
Jul 9, 2011
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Hello

My code that copies data from cells to an ordered list, then clears the original cells, and then copies data from the list to a different position on the form...essentially rotating the data. I believe my code is very clumsy and not efficient. I am hopeful someone can provide some guidance...

Code: 
Sub Macro1()
    
    ActiveSheet.Unprotect


    Range("C27:F27").Select
    Selection.Copy
    Range("N27").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C27:F28").Select
    Selection.ClearContents


    Range("C31:F31").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("N28").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C31:F32").Select
    Selection.ClearContents
    
    Range("C35:F35").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("N29").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C35:F36").Select
    Selection.ClearContents
    
    Range("J27:K27").Select
    Selection.Copy
    Range("N30").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J27:K28").Select
    Selection.ClearContents
    
    Range("J31:K31").Select
    Selection.Copy
    Range("N31").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J31:K32").Select
    Selection.ClearContents
    
    Range("J35:K35").Select
    Selection.Copy
    Range("N32").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J35:K36").Select
    Selection.ClearContents
    
    Range("C41:F41").Select
    Selection.Copy
    Range("N33").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C41:F42").Select
    Selection.ClearContents
    
    Range("C45:F45").Select
    Selection.Copy
    Range("N34").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C45:F46").Select
    Selection.ClearContents
    
    Range("C49:F49").Select
    Selection.Copy
    Range("N35").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C49:F50").Select
    Selection.ClearContents
    
    Range("J41:K41").Select
    Selection.Copy
    Range("N36").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J41:K42").Select
    Selection.ClearContents


    Range("J45:K45").Select
    Selection.Copy
    Range("N37").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J45:K46").Select
    Selection.ClearContents
    
    Range("J49:K49").Select
    Selection.Copy
    Range("N38").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J49:K50").Select
    Selection.ClearContents
    
    Range("C55:F55").Select
    Selection.Copy
    Range("N39").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C55:F56").Select
    Selection.ClearContents
    
    Range("C59:F59").Select
    Selection.Copy
    Range("N40").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C59:F60").Select
    Selection.ClearContents
    
    Range("C63:F63").Select
    Selection.Copy
    Range("N41").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C63:F64").Select
    Selection.ClearContents


    Range("C67:F67").Select
    Selection.Copy
    Range("N42").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C67:F68").Select
    Selection.ClearContents
    
    Range("N27").Select
    Selection.Copy
    Range("J31:K31").Select
    ActiveSheet.Paste
    
    Range("N28").Select
    Selection.Copy
    Range("J35:K35").Select
    ActiveSheet.Paste
    
    Range("N29").Select
    Selection.Copy
    Range("J27:K27").Select
    ActiveSheet.Paste
    
    Range("N30").Select
    Selection.Copy
    Range("C45:F45").Select
    ActiveSheet.Paste
    
    Range("N31").Select
    Selection.Copy
    Range("C49:F49").Select
    ActiveSheet.Paste
    
    Range("N32").Select
    Selection.Copy
    Range("C41:F41").Select
    ActiveSheet.Paste
    
    Range("N33").Select
    Selection.Copy
    Range("J45:K45").Select
    ActiveSheet.Paste
    
    Range("N34").Select
    Selection.Copy
    Range("J49:K49").Select
    ActiveSheet.Paste
    
    Range("N35").Select
    Selection.Copy
    Range("J41:K41").Select
    ActiveSheet.Paste
    
    Range("N36").Select
    Selection.Copy
    Range("C59:F59").Select
    ActiveSheet.Paste
    
    Range("N37").Select
    Selection.Copy
    Range("C63:F63").Select
    ActiveSheet.Paste
    
    Range("N38").Select
    Selection.Copy
    Range("C55:F55").Select
    ActiveSheet.Paste
    
    Range("N39").Select
    Selection.Copy
    Range("C31:F31").Select
    ActiveSheet.Paste
    
    Range("N40").Select
    Selection.Copy
    Range("C35:F35").Select
    ActiveSheet.Paste
    
    Range("N41").Select
    Selection.Copy
    Range("C67:F67").Select
    ActiveSheet.Paste
    
    Range("N42").Select
    Selection.Copy
    Range("C27:F27").Select
    ActiveSheet.Paste
    
    Range("N27:N42").Select
    Selection.ClearContents
    
    Range("K8").Select
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
You can get rid of all the .Select & Selection. like
Code: 
   Range("N27:Q27").Value = Range("C27:F27").Value
   Range("C27:F28").ClearContents
   Range("N28:Q28").Value = Range("C31:F31").Value
   Range("C31:F32").ClearContents
 
Upvote 0
thank you Fluff

I finished with this code...

Code: 
Sub Macro1()    
    ActiveSheet.Unprotect
    
    Range("N27").Value = Range("C27:F27").Value
    Range("C27:F28").ClearContents
    Range("N28").Value = Range("C31:F31").Value
    Range("C31:F32").ClearContents
    Range("N29").Value = Range("C35:F35").Value
    Range("C35:F36").ClearContents
    Range("N30").Value = Range("J27:K27").Value
    Range("J27:K28").ClearContents
    Range("N31").Value = Range("J31:K31").Value
    Range("J31:K32").ClearContents
    Range("N32").Value = Range("J35:K35").Value
    Range("J35:K36").ClearContents
    Range("N33").Value = Range("C41:F41").Value
    Range("C41:F42").ClearContents
    Range("N34").Value = Range("C45:F45").Value
    Range("C45:F46").ClearContents
    Range("N35").Value = Range("C49:F49").Value
    Range("C49:F50").ClearContents
    Range("N36").Value = Range("J41:K41").Value
    Range("J41:K42").ClearContents
    Range("N37").Value = Range("J45:K45").Value
    Range("J45:K46").ClearContents
    Range("N38").Value = Range("J49:K49").Value
    Range("J49:K50").ClearContents
    Range("N39").Value = Range("C55:F55").Value
    Range("C55:F56").ClearContents
    Range("N40").Value = Range("C59:F59").Value
    Range("C59:F60").ClearContents
    Range("N41").Value = Range("C63:F63").Value
    Range("C63:F64").ClearContents
    Range("N42").Value = Range("C67:F67").Value
    Range("C67:F68").ClearContents
    
    Range("N27").Select
    Selection.Copy
    Range("J31:K31").Select
    ActiveSheet.Paste
    
    Range("N28").Select
    Selection.Copy
    Range("J35:K35").Select
    ActiveSheet.Paste
    
    Range("N29").Select
    Selection.Copy
    Range("J27:K27").Select
    ActiveSheet.Paste
    
    Range("N30").Select
    Selection.Copy
    Range("C45:F45").Select
    ActiveSheet.Paste
    
    Range("N31").Select
    Selection.Copy
    Range("C49:F49").Select
    ActiveSheet.Paste
    
    Range("N32").Select
    Selection.Copy
    Range("C41:F41").Select
    ActiveSheet.Paste
    
    Range("N33").Select
    Selection.Copy
    Range("J45:K45").Select
    ActiveSheet.Paste
    
    Range("N34").Select
    Selection.Copy
    Range("J49:K49").Select
    ActiveSheet.Paste
    
    Range("N35").Select
    Selection.Copy
    Range("J41:K41").Select
    ActiveSheet.Paste
    
    Range("N36").Select
    Selection.Copy
    Range("C59:F59").Select
    ActiveSheet.Paste
    
    Range("N37").Select
    Selection.Copy
    Range("C63:F63").Select
    ActiveSheet.Paste
    
    Range("N38").Select
    Selection.Copy
    Range("C55:F55").Select
    ActiveSheet.Paste
    
    Range("N39").Select
    Selection.Copy
    Range("C31:F31").Select
    ActiveSheet.Paste
    
    Range("N40").Select
    Selection.Copy
    Range("C35:F35").Select
    ActiveSheet.Paste
    
    Range("N41").Select
    Selection.Copy
    Range("C67:F67").Select
    ActiveSheet.Paste
    
    Range("N42").Select
    Selection.Copy
    Range("C27:F27").Select
    ActiveSheet.Paste
    
    Range("N27:N42").Select
    Selection.ClearContents
    
    Range("K8").Select
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
End Sub

Is there a way of cutting out the double process to do it all in one step?
 
Upvote 0
Maybe:
Code: 
Sub Macro1()
    ActiveSheet.Unprotect
    Application.ScreenUpdating = False
    Dim x As Long
    Dim y As Long
    y = 27
    For x = 27 To 35 Step 4
        Range("C" & x & ":F" & x).Copy
        Range("N" & y).PasteSpecial Paste:=xlPasteValues
        Range("C" & x & ":F" & x + 1).ClearContents
        y = y + 1
    Next x
    y = 33
    For x = 41 To 49 Step 4
        Range("C" & x & ":F" & x).Copy
        Range("N" & y).PasteSpecial Paste:=xlPasteValues
        Range("C" & x & ":F" & x + 1).ClearContents
        y = y + 1
    Next x
    y = 39
    For x = 55 To 67 Step 4
        Range("C" & x & ":F" & x).Copy
        Range("N" & y).PasteSpecial Paste:=xlPasteValues
        Range("C" & x & ":F" & x + 1).ClearContents
        y = y + 1
    Next x
    y = 30
    For x = 27 To 35 Step 4
        Range("J" & x & ":K" & x).Copy
        Range("N" & y).PasteSpecial Paste:=xlPasteValues
        Range("J" & x & ":K" & x + 1).ClearContents
        y = y + 1
    Next x
    y = 36
    For x = 41 To 49 Step 4
        Range("J" & x & ":K" & x).Copy
        Range("N" & y).PasteSpecial Paste:=xlPasteValues
        Range("J" & x & ":K" & x + 1).ClearContents
        y = y + 1
    Next x
    Range("J31:K31") = Range("N27")
    Range("J35:K35") = Range("N28")
    Range("J27:K27") = Range("N29")
    Range("C45:F45") = Range("N30")
    Range("C49:F49") = Range("N31")
    Range("C41:F41") = Range("N32")
    Range("J45:K45") = Range("N33")
    Range("J49:K49") = Range("N34")
    Range("J41:K41") = Range("N35")
    Range("C59:F59") = Range("N36")
    Range("C63:F63") = Range("N37")
    Range("C55:F55") = Range("N38")
    Range("C31:F31") = Range("N39")
    Range("C35:F35") = Range("N40")
    Range("C67:F67") = Range("N41")
    Range("C27:F27") = Range("N42")
    Range("N27:N42").ClearContents
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Mumps, thank you...that works exactly as I had hoped for. I appreciate yours and Fluffs time.
 
Upvote 0
Are the ranges you are copying from merged cells?
 
Upvote 0
If the answer to post#6 is yes, you could also use
Code: 
Sub CopyData()
   Dim ary1 As Variant
   Dim ary2 As Variant
   Dim i As Long
   
   ary1 = Array("C27", "C31", "C35", "J27", "J31", "J35", "C41", "C45", "C49", "J41", "J45", "J49")
   ary2 = Array("J31", "J35", "J27", "C45", "C49", "C41", "J45", "J49", "J41")
   For i = 0 To UBound(ary1)
      Range("N" & i + 27).Value = Range(ary1(i)).Value
      Range(ary1(i)).Resize(2).ClearContents
   Next i
   For i = 0 To UBound(ary2)
      Range(ary2(i)).Value = Range("N" & i + 27).Value
   Next i
End Sub
expanding the arrays as needed
 
Last edited:
Upvote 0
twothings said:
Is there a way of cutting out the double process to do it all in one step?
Click to expand...
If you are still interested in this, and the ranges in columns C:F and in J:K are merged, then I think you can avoid using column N as follows. Test in a copy of your workbook.
Code: 
Sub ReCycle_Cells()
  Dim a As Variant
  Dim c As Range
  Dim r As Long
  
  a = Application.Index(Range("C67,C55,C59,J35,J27,J31,J49,J41,J45,C63,C35,C27,C31,C49,C41,C45"), 1, 1, Application.Transpose(Evaluate("row(1:16)")))
  For Each c In Range("C27,C31,C35,C41,C45,C49,C55,C59,C63,C67,J27,J31,J35,J41,J45,J49")
    r = r + 1
    c.Value = a(r)
  Next c
End Sub

If you don't have merged cells in those ranges mentioned, then post back with more details as more clarification may be required.


Edit: I was testing on an unprotected sheet so you may have to add the unprotect/reprotect lines back in.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
87
myall_blues
myall_blues
C
  • Solved
Please help me clean up my VBA script, I'm having trouble with redundancies
Replies
4
Views
104
CapRavOr
C
D
  • Question
VBA optimization advice
Replies
3
Views
147
bobsan42
bobsan42
P
  • Solved
Counter in For Each loop
Replies
2
Views
215
Possum17
P
P
  • Solved
Need help with macro Dynamic Range??
Replies
6
Views
207
pennbowl
P

Forum statistics

Threads
1,215,545
Messages
6,125,455
Members
449,228
Latest member
moaz_cma

Share this page

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
Back
Top