Consolidate ever growing VBA

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,075
Hello!

I Have been trying to find a create way to copy and paste values using VBA, and while it does work perfectly, As I add more cells to my list, the VBA code gets longer and longer. Anyone have any suggestion for how I can consolidate this code? There are multiple other pieces, but they all follow a similar pattern of cell locations, heres the code:
VBA Code:
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Thank you!
 

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

jmacleary

Well-known Member
Joined
Oct 5, 2015
Messages
1,056
Office Version
  1. 365
  2. 2007
Platform
  1. Windows
Hi Drew

I assume you are doing some sort of operation on the selected cell when you run the DUP1C code.

I have left your code as like as possible to yours. This in completely untested, but should work unless you switch selection in the DUPC code):
VBA Code:
Sub tester()
Dim StartfromCol As Long
Dim EndCol As Long
Dim ToCol As Long
Dim ThisCol As Long

ToCol = 4
StartfromCol = 29
EndCol = 33 ' set this to the column number of the last column to process
For ThisCol = StartfromCol To EndCol

    With Sheets("Large_Set")
        .Cells(1, ThisCol).Select
        Application.Run "Module2.DUP1C"
        .Cells(9, ToCol).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
    End With
    ToCol = ToCol + 1
Next ThisCol

End Sub
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,271
Office Version
  1. 365
Platform
  1. Windows
Perhaps something like this.
VBA Code:
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(1)
   
        Set rngDst = rngDst.Offset(, 1)
    Next idx
 

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,075
Perhaps something like this.
VBA Code:
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(1)
  
        Set rngDst = rngDst.Offset(, 1)
    Next idx
Norie, I'm getting a 1004 error on
VBA Code:
Application.Goto rngSrc
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,271
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

There's actually a typo in my code, but it shouldn't cause the error you describe.
VBA Code:
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(,1)
   
        Set rngDst = rngDst.Offset(, 1)
    Next idx

What does the code DUP1C in Module2 actually do?
 

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,075
Hi Drew

I assume you are doing some sort of operation on the selected cell when you run the DUP1C code.

I have left your code as like as possible to yours. This in completely untested, but should work unless you switch selection in the DUPC code):
VBA Code:
Sub tester()
Dim StartfromCol As Long
Dim EndCol As Long
Dim ToCol As Long
Dim ThisCol As Long

ToCol = 4
StartfromCol = 29
EndCol = 33 ' set this to the column number of the last column to process
For ThisCol = StartfromCol To EndCol

    With Sheets("Large_Set")
        .Cells(1, ThisCol).Select
        Application.Run "Module2.DUP1C"
        .Cells(9, ToCol).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
    End With
    ToCol = ToCol + 1
Next ThisCol

End Sub
I'm getting a 1004 error on this too, now I'm wondering if I am doing something weird...
 

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,075
There's actually a typo in my code, but it shouldn't cause the error you describe.
VBA Code:
Dim rngSrc As Range
Dim rngDst As Range
Dim idx As Long

    Set rngSrc = Sheets("Large_Set").Range("AC1")
    Set rngDst = Sheets("Large_Set").Range("D9")

    For idx = 1 To 9
        Application.Goto rngSrc
        Application.Run "Module2.DUP1C"

        rngDst.PasteSpecial Paste:=xlPasteValues

        Set rngSrc = rngSrc.Offset(,1)
  
        Set rngDst = rngDst.Offset(, 1)
    Next idx

What does the code DUP1C in Module2 actually do?
Here is the entire code:
VBA Code:
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Run "Module5.destructure"
'individual stats
    Sheets("Large_Set").Range("$A$1:$HW$4001").AutoFilter Field:=1, Criteria1:=BYMODEL.ComboBox3.Value
    
'***********ID #******************
Sheets("Large_Set").Visible = True
Sheets("Large_Set").Select
Range("A1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G5").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("G5:H5").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Year******************
Sheets("Large_Set").Select
Range("D1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("D3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'----------------------------------------------
'***********make******************
Sheets("Large_Set").Select
Range("B1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("F3:H3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********model******************
Sheets("Large_Set").Select
Range("C1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("J3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("I3:K3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Revenue******************
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


Application.DisplayAlerts = True
Application.Run "Module5.structure"
Application.ScreenUpdating = True
'need to reset merged cells prior to restart
End Sub

And here is the DUP1C:
VBA Code:
Sub DUP1C()
'insert row 1 range select
ActiveCell.Offset(1, 0).Activate
Do Until Selection.EntireRow.Hidden = False
If Selection.EntireRow.Hidden = True Then
ActiveCell.Offset(1, 0).Activate
End If
Loop
ActiveCell.Select
Selection.Copy
    Sheets("CAR_STATS").Select
   ' Range("???").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
End Sub
 

andrewb90

Well-known Member
Joined
Dec 16, 2009
Messages
1,075
Here is the entire code:
VBA Code:
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Run "Module5.destructure"
'individual stats
    Sheets("Large_Set").Range("$A$1:$HW$4001").AutoFilter Field:=1, Criteria1:=BYMODEL.ComboBox3.Value
   
'***********ID #******************
Sheets("Large_Set").Visible = True
Sheets("Large_Set").Select
Range("A1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G5").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("G5:H5").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Year******************
Sheets("Large_Set").Select
Range("D1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("D3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'----------------------------------------------
'***********make******************
Sheets("Large_Set").Select
Range("B1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("G3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("F3:H3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********model******************
Sheets("Large_Set").Select
Range("C1").Select      'data column choice
Application.Run "Module2.COPYCAR"
Range("J3").Select      'pasting location
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("I3:K3").Select    'optional merge
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
'----------------------------------------------
'***********Revenue******************
Sheets("Large_Set").Select
Range("AC1:AC1").Select
Application.Run "Module2.DUP1C"
Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AD1:AD1").Select
Application.Run "Module2.DUP1C"
Range("E9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AE1:AE1").Select
Application.Run "Module2.DUP1C"
Range("F9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AF1:AF1").Select
Application.Run "Module2.DUP1C"
Range("G9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AG1:AG1").Select
Application.Run "Module2.DUP1C"
Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AH1:AH1").Select
Application.Run "Module2.DUP1C"
Range("I9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AI1:AI1").Select
Application.Run "Module2.DUP1C"
Range("J9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AJ1:AJ1").Select
Application.Run "Module2.DUP1C"
Range("K9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("Large_Set").Select
Range("AK1:AK1").Select
Application.Run "Module2.DUP1C"
Range("L9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Large_Set").Select
Range("AL1:AL1").Select
Application.Run "Module2.DUP1C"
Range("M9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


Application.DisplayAlerts = True
Application.Run "Module5.structure"
Application.ScreenUpdating = True
'need to reset merged cells prior to restart
End Sub

And here is the DUP1C:
VBA Code:
Sub DUP1C()
'insert row 1 range select
ActiveCell.Offset(1, 0).Activate
Do Until Selection.EntireRow.Hidden = False
If Selection.EntireRow.Hidden = True Then
ActiveCell.Offset(1, 0).Activate
End If
Loop
ActiveCell.Select
Selection.Copy
    Sheets("CAR_STATS").Select
   ' Range("???").Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
End Sub
Module2.CopyCar is identical to DUP1C currently.
Module5.structure/destructure unlock and relock the workbook.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,660
Messages
5,626,152
Members
416,165
Latest member
hamburger138

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