Practing vba code with copy and pasting , need help

ILeonFF

New Member
Joined
Jun 20, 2018
Messages
18
How do i go about consolidating this VBA Code for copying and pasting

Code:
Sub Button24_Click()
Sheets("General Information").Select
    ActiveWindow.SmallScroll Down:=27
    Range("D53:F53").Select
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B3").Select
    Sheets("General Information").Select
    Range("D55:F55").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B4").Select
    Sheets("General Information").Select
    Range("D56:F56").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B5").Select
    Sheets("FA-PCIF Header").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B6").Select
    Sheets("General Information").Select
    ActiveWindow.SmallScroll Down:=-27
    Range("D17").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B7").Select
    Sheets("General Information").Select
    Range("E17:F17").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B8").Select
    Sheets("General Information").Select
    Range("D19").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B9").Select
    Sheets("General Information").Select
    Range("D12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("B10").Select
    Sheets("General Information").Select
    ActiveWindow.SmallScroll Down:=9
    Range("D33").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("B11").Select
    Sheets("General Information").Select
    Range("D20:K23").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B12").Select

    Sheets("General Information").Select
    ActiveWindow.SmallScroll Down:=15
    Range("D39").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Mechanical Design Summary").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B16").Select

End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Hi,

What do you mean by "consolidation"?

By the look of the code it has come from a recorded macro?

Is it running too slow for you?

A couple of quick tips-

1. delete the scroll parts of the code.
2. you don't need to "select" anything to do something.
3. adding
Code:
ScreenUpdating=False
at the beginning of your code and
Code:
ScreenUpdating=True
at the end of your code will made it run faster.

hope that helps,

FS
 
Upvote 0
Hi,

What do you mean by "consolidation"?

By the look of the code it has come from a recorded macro?

Is it running too slow for you?

A couple of quick tips-

1. delete the scroll parts of the code.
2. you don't need to "select" anything to do something.
3. adding
Code:
ScreenUpdating=False
at the beginning of your code and
Code:
ScreenUpdating=True
at the end of your code will made it run faster.

hope that helps,

FS

Yeah its a recorded macro. What i mean by consolidation is to essentially remove any redundancies if possible and if there are any rewrites in the code just to make it more condensed(if that makes any sense).
Thank you for your suggestions i have implemented them.
 
Upvote 0
You can get rid of the .Select & Selection like this
Code:
With Sheets("General Information")
   .Range("D53:F53").Copy
   Sheets("Mechanical Design Summary").Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   
   .Range("D55:F55").Copy
   Sheets("Mechanical Design Summary").Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   
   .Range("D56:F56").Copy
   Sheets("Mechanical Design Summary").Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End With
It could also be slimmed down further by the use of loops.But if you rewrite your code like I've shown (& check that it works), then post that to the board, we can have another look
 
Upvote 0
You can get rid of the .Select & Selection like this
Code:
With Sheets("General Information")
   .Range("D53:F53").Copy
   Sheets("Mechanical Design Summary").Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   
   .Range("D55:F55").Copy
   Sheets("Mechanical Design Summary").Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   
   .Range("D56:F56").Copy
   Sheets("Mechanical Design Summary").Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End With
It could also be slimmed down further by the use of loops.But if you rewrite your code like I've shown (& check that it works), then post that to the board, we can have another look

Okay i have added everything that was suggested. And everything works great. Thank you so much. Here is the code below
Code:
Sub Macro4()
ScreenUpdating = False
'
  With Sheets("General Information")
   .Range("D53:F53").Copy
   Sheets("Mechanical Design Summary").Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
        
    .Range("D55:F55").Copy
   Sheets("Mechanical Design Summary").Range("B3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
        
    .Range("D56:F56").Copy
   Sheets("Mechanical Design Summary").Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
          
    .Range("D17").Copy
   Sheets("Mechanical Design Summary").Range("B6").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
       
    .Range("E17:F17").Copy
   Sheets("Mechanical Design Summary").Range("B7").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
       
   .Range("D19").Copy
   Sheets("Mechanical Design Summary").Range("B8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
        
    [COLOR=#ff0000].Range("D12").Copy
   Sheets("Mechanical Design Summary").Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False[/COLOR]
           
     [COLOR=#000000].Range("D33").Copy
   Sheets("Mechanical Design Summary").Range("B10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False[/COLOR]
       
    .Range("D20:K23").Copy
   Sheets("Mechanical Design Summary").Range("B11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    
    .Range("D39").Copy
   Sheets("Mechanical Design Summary").Range("B12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
        
End With
      
With Sheets("FA-PCIF Header")
   .Range("D17:I17").Copy
   Sheets("Mechanical Design Summary").Range("B5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
       
End With

ScreenUpdating = True
End Sub

For the text code in red i need to have an IF statement in them. How would i go about adding something like this?:
Code:
[COLOR=#ff0000]
[/COLOR][COLOR=#008000]If "D12" = "None" [/COLOR][COLOR=#ff0000]
[/COLOR][COLOR=#008000].Range("E12:F12").Copy[/COLOR][COLOR=#ff0000]
   Sheets("Mechanical Design Summary").Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
[/COLOR][COLOR=#008000]Else [/COLOR]
[COLOR=#ff0000][COLOR=#ff0000].Range("D12").Copy
   Sheets("Mechanical Design Summary").Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False[/COLOR][/COLOR]
 
Last edited:
Upvote 0
Ok, try this
Code:
Sub Macro4()
   Dim Ary As Variant, i As Long
Application.ScreenUpdating = False

   Ary = Array("D53:F53", "D55:F55", "D56:F56", "", "D17", "E17:F17", "D19", "D12", "D33", "D20:K23", "D39")
   With Sheets("General Information")
      For i = 0 To UBound(Ary)
         If Not Ary(i) = vbNullString Then
            If Ary(i) = "D12" And .Range("D12") = "None" Then Ary(i) = "E12:F12"
            .Range(Ary(i)).Copy
            Sheets("Mechanical Design Summary").Range("B" & i + 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
         End If
      Next i
   End With

   With Sheets("FA-PCIF Header")
      .Range("D17:I17").Copy
      Sheets("Mechanical Design Summary").Range("B5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
   End With

Application.ScreenUpdating = True
End Sub
 
Upvote 0
Ok, try this
Code:
Sub Macro4()
   Dim Ary As Variant, i As Long
Application.ScreenUpdating = False

   Ary = Array("D53:F53", "D55:F55", "D56:F56", "", "D17", "E17:F17", "D19", "D12", "D33", "D20:K23", "D39")
   With Sheets("General Information")
      For i = 0 To UBound(Ary)
         If Not Ary(i) = vbNullString Then
            If Ary(i) = "D12" And .Range("D12") = "None" Then Ary(i) = "E12:F12"
            .Range(Ary(i)).Copy
            Sheets("Mechanical Design Summary").Range("B" & i + 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
         End If
      Next i
   End With

   With Sheets("FA-PCIF Header")
      .Range("D17:I17").Copy
      Sheets("Mechanical Design Summary").Range("B5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
   End With

Application.ScreenUpdating = True
End Sub

Everything worked like a charm thank you once again.
Can you explain what is going on with this part in the code. I need to add another exception just like "D12" but for "D33", was hoping it'd be simple to add in there but im a little lost on whats going on in the code.

Code:
For i = 0 To UBound(Ary)          
            If Not Ary(i) = vbNullString Then
            If Ary(i) = "D12" And .Range("D12") = "None" Then Ary(i) = "E12:F12"
            .Range(Ary(i)).Copy
            Sheets("Mechanical Design Summary").Range("B" & i + 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
        End If
     Next i
 
Last edited:
Upvote 0
This part of the code is looping through the array
Code:
      For i = 0 To UBound(Ary)
         [COLOR=#ff0000]If Not Ary(i) = vbNullString Then[/COLOR]
            [COLOR=#0000ff]If Ary(i) = "D12" And .Range("D12") = "None" Then Ary(i) = "E12:F12"[/COLOR]
            .Range(Ary(i)).Copy
            Sheets("Mechanical Design Summary").Range("B" & i + 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
         End If
      Next i
So for the first time through it will copy range D53:F53, then next time it will copy D55:F55 etc.
The part in red checks to see if the value in the array is "". This is in order to skip pasting data to cell B5
The part in blue checks to see if the array value is D12 & if so it checks if D12=None. If it does it replaces the value in the array with E12:F12
To check the value of D33 you can copy the blue line, & paste underneath, then modify as required.
 
Upvote 0
This part of the code is looping through the array
Code:
      For i = 0 To UBound(Ary)
         [COLOR=#ff0000]If Not Ary(i) = vbNullString Then[/COLOR]
            [COLOR=#0000ff]If Ary(i) = "D12" And .Range("D12") = "None" Then Ary(i) = "E12:F12"[/COLOR]
            .Range(Ary(i)).Copy
            Sheets("Mechanical Design Summary").Range("B" & i + 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
         End If
      Next i
So for the first time through it will copy range D53:F53, then next time it will copy D55:F55 etc.
The part in red checks to see if the value in the array is "". This is in order to skip pasting data to cell B5
The part in blue checks to see if the array value is D12 & if so it checks if D12=None. If it does it replaces the value in the array with E12:F12
To check the value of D33 you can copy the blue line, & paste underneath, then modify as required.

Your explanation was perfect, Thank you.
 
Upvote 0

Forum statistics

Threads
1,213,561
Messages
6,114,312
Members
448,564
Latest member
ED38

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