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

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
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

N
  • Question Question
Adding to an existing MACRO
Replies
2
Views
103
Northern NY Design
N
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
211
kbk
K
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
280
willow1985
willow1985
S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
152
MikeVol
MikeVol
C
  • Question Question
Please help clean up my convoluted VBA code. It seems very redundant and repetitive.
Replies
1
Views
429
myall_blues
myall_blues

Forum statistics

Threads
1,223,898
Messages
6,175,274
Members
452,628
Latest member
dd2

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